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

View of /FigWebServices/subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (download) (annotate)
Thu Sep 9 02:31:00 2004 UTC (15 years, 7 months ago) by overbeek
Branch: MAIN
Changes since 1.1: +1 -1 lines
minor fixes

# -*- perl -*-

use FIG;
my $fig = new FIG;
use Subsystem;

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

# request to display the phylogenetic tree
#
my $request = $cgi->param("request");
if ($request && ($request eq "show_tree"))
{
    print $cgi->header;
    &show_tree;
    exit;
}

my $html = [];

my $user = $cgi->param('user');
$fig->set_user($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("extend_with_billogix"))
{
    #
    # Start a bg task to extend the subsystem.
    #

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

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

    my $sub = $fig->get_subsystem($ssa);

    if ($sub)
    {
	#
	# See if there's already an extend job running.
	#
	    
	my $curpid = $sub->get_current_extend_pid();
	if ($curpid)
	{
	    warn "Found current pid $curpid\n";
	    my $j = $fig->get_job($curpid);
	    warn "job is $j\n";
	    warn "running is ", $j->running(), "\n" if $j;
	    if ($j && $j->running())
	    {
		push(@$html, "Subsystem extension is already running as job number $curpid. <br>",
		     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
		last;
	    }
	}
	
	my $pid = $fig->run_in_background(sub {$sub->extend_with_billogix($user);});
	    
	push(@$html,
	     "Subsystem extension started as background job number $pid <br>\n",
	     "Click <a href=\"seed_ctl.cgi\">here</a> to see currently running jobs and their status");
	    
	$sub->set_current_extend_pid($pid);
    }
    else
    {
	push(@$html, "Subsystem '$ssa' could not be loaded");
    }
    &HTML::show_page($cgi, $html);
    exit;
}
else
{
    $request = defined($request) ? $request : "";

    if    ($request eq "reset")
    {
	&reset_ssa($fig,$cgi,$html);        # allow user to go back to a previous version of the ss
    }
    elsif    ($request eq "reset_to")
    {
	&reset_ssa_to($fig,$cgi,$html);     # this actually resets to the previous version
	&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")
    {
	&one_cycle($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 $sub = $fig->get_subsystem($ssa);
	    $sub->delete_indices();
	    
	    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") && ($cgi->param('copy_from1')) && (! $cgi->param('cols_to_take1')))
    {
	my $user = $cgi->param('user');
	my $name = $cgi->param('ssa_name');
	my $copy_from1 = $cgi->param('copy_from1');
	my $copy_from2 = $cgi->param('copy_from2');
        my(@roles1,@roles2);

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

	@roles1 = $fig->subsystem_to_roles($copy_from1);
	if (@roles1 > 0)
	{
	    push(@$html,$cgi->h1("select columns to be taken from $copy_from1"),
		        $cgi->scrolling_list(-name => 'cols_to_take1',
					     -values => ['all',@roles1],
					     -size => 10,
					     -multiple => 1
					     ),
		        $cgi->hr
	     );
	}

	if ($copy_from2)
	{
	    @roles2 = $fig->subsystem_to_roles($copy_from2);
	    if (@roles2 > 0)
	    {
		push(@$html,$cgi->hidden(-name => 'copy_from2', -value => $copy_from2, -override => 1));
		push(@$html,$cgi->h1("select columns to be taken from $copy_from2"),
		            $cgi->scrolling_list(-name => 'cols_to_take2',
						 -values => ['all',@roles2],
						 -size => 10,
						 -multiple => 1
						 ),
		            $cgi->hr
		     );
	    }
	}
	push(@$html,$cgi->submit('build new subsystem'),
	            $cgi->end_form
	     );
    }
    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 or Copy a Subsystem'),
                 $cgi->start_form(-action => "subsys.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: ",
	         $cgi->textfield(-name => "ssa_name", -size => 50),
	         $cgi->hidden(-name => 'can_alter', -value => 1, -override => 1),
	         $cgi->br,

	         "Copy from (leave blank to start from scratch): ",
	         $cgi->textfield(-name => "copy_from1", -size => 50),
	         $cgi->br,

	         "Copy from (leave blank to start from scratch): ",
	         $cgi->textfield(-name => "copy_from2", -size => 50),
	         $cgi->br,

	         $cgi->submit('start new subsystem'),
	         $cgi->end_form,
	         "<br>You can start a subsystem from scratch, in which case you should leave these two \"copy from\"
fields blank.  If you wish to just copy a subsystem (in order to become the owner so that you can modify it),
just fill in one of the \"copy from\" fields with the name of the subsystem you wish to copy.  If you wish to
extract a a subset of the columns to build a smaller spreadsheet (which could later be merged with another one),
fill in the name of the subsystem.  You will be prompted for the columns that you wish to extract (choose <i>all</i> to
just copy all of the columns).  Finally, if you wish to build a new spreadsheet by including columns from two existing
spreadsheets (including a complete merger), fill in the names of both the existing \"copy from\" subsystems"
	 );
}		  

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

    my $subsystem = new Subsystem($ssa,$fig,1);    # create new subsystem

    my $copy_from1 = $cgi->param('copy_from1');
    $copy_from1 =~ s/[ \/]/_/g;
    my $copy_from2 = $cgi->param('copy_from2');
    $copy_from2 =~ s/[ \/]/_/g;
    my @cols_to_take1 = $cgi->param('cols_to_take1');
    my @cols_to_take2 = $cgi->param('cols_to_take2');

    
    if ($copy_from1 && (@cols_to_take1 > 0))
    {
	$subsystem->add_to_subsys($copy_from1,\@cols_to_take1,"take notes");  # add columns and notes
    }

    if ($copy_from2 && (@cols_to_take2 > 0))
    {
	$subsystem->add_to_subsys($copy_from2,\@cols_to_take2,"take notes");  # add columns and notes
    }

    $subsystem->write_subsystem();

    $cgi->param(-name => "can_alter",
		-value => 1);
    &one_cycle($fig,$cgi,$html);
}

# The basic update logic (cycle) includes the following steps:
# 
#     1. Load the existing spreadsheet
#     2. reconcile row and subset changes
#     3. process spreadsheet changes (fill/refill/add genomes)
#     4. write the updated spreadsheet back to disk
#     5. render the spreadsheet
#
sub one_cycle {
    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 $subsystem = new Subsystem($ssa,$fig,0);
    if (&handle_role_and_subset_changes($fig,$subsystem,$cgi,$html))
    {
	&process_spreadsheet_changes($fig,$subsystem,$cgi,$html);
	$subsystem->write_subsystem();
	&produce_html_to_display_subsystem($fig,$subsystem,$cgi,$html);
    }
}

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

    if (! $cgi->param('can_alter'))
    {
	return 1;    # no changes, so...
    }
    else
    {
	my($role,$p,$abr,$r,$n);
	my @tuplesR = ();
	my @roles   = grep { $_ =~ /^role/ }   $cgi->param();
	if (@roles == 0)  { return 1 }     # initial call, everything is as it was

	foreach $role (@roles)
	{
	    if (($role =~ /^role(\d+)/) && defined($n = $1))
	    {
		if ($r = $cgi->param("role$n"))
		{
		    if (($p = $cgi->param("posR$n")) && ($abr = $cgi->param("abbrev$n")))
		    {
			push(@tuplesR,[$p,$r,$abr]);
		    }
		    else
		    {
			push(@$html,$cgi->h1("You need to give a position and abbreviation for $r"));
			return 0;
		    }
		}
	    }
	}
	$subsystem->set_roles([map { [$_->[1],$_->[2]] } sort { $a->[0] <=> $b->[0] } @tuplesR]);

	my($subset_name,$s,$test,@entries,$entry);
	my @subset_names  = grep { $_ =~ /^subset_name/ } $cgi->param();
	foreach $subset_name (@subset_names)
	{
	    if (($subset_name =~ /^subset_name(\d+)/) && defined($n = $1) && ($s = $cgi->param("nameCS$n")))
	    {
		my($text);
		if ($text = $cgi->param("subset$n"))
		{
		    @entries = ();
		    foreach $entry (split(/[\s,]+/,$text))
		    {
			if ($role = &to_role($entry,\@tuplesR))
			{
			    push(@entries,$role);
			}
			else
			{
			    push(@$html,$cgi->h1("Invalid role designation in subset $s: $entry"));
			    return 0;
			}
		    }
		    $subsystem->set_subset($s,\@entries);
		}
	    }
	}
    }
    return 1;
}

sub to_role {
    my($x,$role_tuples) = @_;
    my $i;

    for ($i=0; ($i < @$role_tuples) && 
	       ($role_tuples->[0] != $x) &&
	       ($role_tuples->[1] != $x) &&
	 ($role_tuples->[2] != $x); $i++) {}
    if ($i < @$role_tuples)
    {
	return $role_tuples->[$i]->[1];
    }
    return undef;
}
    
sub process_spreadsheet_changes {
    my($fig,$subsystem,$cgi,$html) = @_;

    if (! $cgi->param('can_alter'))
    {
	return 1;    # no changes, so...
    }
    else
    {
	if ($cgi->param('refill'))
	{
	    &refill_spreadsheet($fig,$subsystem);
	}
	elsif ($cgi->param('precise_fill'))
	{
	    &fill_empty_cells($fig,$subsystem);
	}

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

	my $org;
	foreach $org (@orgs)
	{
	    &add_genome($fig,$subsystem,$cgi,$html,$org);
	}
    }
}

sub refill_spreadsheet {
    my($fig,$subsystem) = @_;
    my($genome,$role,@pegs);

    foreach $genome ($subsystem->get_genomes())
    {
	foreach $role ($subsystem->get_roles())
	{
	    @pegs = $fig->seqs_with_role($role,"master",$genome);
	    $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
	}
    }
}

sub fill_empty_cells {
    my($fig,$subsystem) = @_;
    my($genome,$role,@pegs);

    foreach $genome ($subsystem->get_genomes())
    {
	foreach $role ($subsystem->get_roles())
	{
	    @pegs = $subsystem->get_pegs_from_cell($genome,$role);
	    if (@pegs == 0)
	    {
		@pegs = $fig->seqs_with_role($role,"master",$genome);
		if (@pegs > 0)
		{
		    $subsystem->set_pegs_in_cell($genome,$role,\@pegs);
		}
	    }
	}
    }
}

sub add_genome {
    my($fig,$subsystem,$cgi,$html,$genome) = @_;
    my($role,@pegs);
    
    $subsystem->add_genome($genome);
    foreach $role ($subsystem->get_roles())
    {
	@pegs = $fig->seqs_with_role($role,"master",$genome);
	$subsystem->set_pegs_in_cell($genome,$role,\@pegs);
    }
}

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

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

    my $name  = $ssa;
    $name =~ s/_/ /g;
    $ssa =~ s/[ \/]/_/g;

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

    &format_roles($fig,$cgi,$html,$subsystem);
    &format_subsets($fig,$cgi,$html,$subsystem);
    &format_rows($fig,$cgi,$html,$subsystem);

    if ($can_alter)
    {
	&format_extend_with($fig,$cgi,$html,$subsystem);
	push(@$html,$cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill'),$cgi->br);
	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 => 'ignore_alt', -value => 1, -checked => 0, -override => 1,-label => 'ignore alternatives'),$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'),
	        "&nbsp; &nbsp; [To restrict to a single genome: ",
                $cgi->textfield(-name => "just_genome", -size => 15),"]",
	        "&nbsp; &nbsp; [To restrict to a single role: ",
                $cgi->textfield(-name => "just_role", -size => 15),"]",
	        $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 => '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),
	     );

    if ($can_alter)
    {
	push(@$html,
	     $cgi->p,
	     $cgi->submit(-value => "Start automated subsystem extension",
			     -name => "extend_with_billogix"),
	     $cgi->br);
    }
    push(@$html, $cgi->end_form);

    push(@$html, $cgi->hr);

    if ($cgi->param('show_missing'))
    {
	&format_missing($fig,$cgi,$html,$subsystem);
    }

    if ($cgi->param('show_missing_including_matches'))
    {
	&format_missing_including_matches($fig,$cgi,$html,$subsystem);
    }

    if ($cgi->param('show_dups'))
    {
	&format_dups($fig,$cgi,$html,$subsystem);
    }

    if ($cgi->param('show_coupled'))
    {
	&format_coupled($fig,$cgi,$html,$subsystem,"careful");
    }
    elsif ($cgi->param('show_coupled_fast'))
    {
	&format_coupled($fig,$cgi,$html,$subsystem,"fast");
    }

    my $col;
    if ($col = $cgi->param('col_to_align'))
    {
	&align_column($fig,$cgi,$html,$col,$subsystem);
    }

    my $notes = $cgi->param('notes');
    if (! $notes)
    {
	$notes = $subsystem->get_notes();
    }
    else
    {
	$subsystem->set_notes($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,$subsystem) = @_;
    my($org,$gs);

    my %genomes = map { $_ => 1 } $subsystem->get_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 => 'new_genome',
				     -values => [@orgs],
				     -size => 10,
				     -multiple => 1
				     ),
	        $cgi->hr
	 );
}

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

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

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

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

    foreach $role ($subsystem->get_roles)
    {
	&format_role($fig,$cgi,$html,$subsystem,$tab,$$nP,$role);
	$$nP++;
    }
}

sub format_role {
    my($fig,$cgi,$html,$subsystem,$tab,$n,$role) = @_;
    my($abbrev);

    $abbrev = $role ? $subsystem->get_role_abbr($subsystem->get_role_index($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 => $role, -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 => $role, -override => 1));
	$posT = $n;
	$abbrevT = $abbrev;
	$roleT = $role;
    }
    #
    # Wrap the first element in the table with a <A NAME="role_rolename"> tag
    # so we can zing to it from elsewhere. We remove any non-alphanumeric
    # chars in the role name.
    #

    my $posT_html;
    {
	my $rn = $role;
	$rn =~ s/[ \/]/_/g;
	$rn =~ s/\W//g;

	$posT_html = "<a name=\"$rn\">$posT</a>";
    }
    

    push(@$tab,[$posT_html,$abbrevT,$roleT]);

    if ($cgi->param('check_problems'))
    {
	my @roles    = grep { $_->[0] ne $role } &gene_functions_in_col($fig,$role,$subsystem);
	my($x,$peg);
	foreach $x (@roles)
	{
	    push(@$tab,["","",$x->[0]]);
	    push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]);
	}
    }
}

sub gene_functions_in_col {
    my($fig,$role,$subsystem) = @_;
    my(%roles,$peg,$func);

                                            # incr by 1 to get col indexed from 1 (not 0)
    my @pegs = map { @$_ } @{$subsystem->get_col($subsystem->get_role_index($role) + 1)}; 
    foreach $peg (@pegs)
    {
	if ($func = $fig->function_of($peg))
	{
	    push(@{$roles{$func}},$peg);
	}
    }
    return map { [$_,$roles{$_}] } sort keys(%roles);
}

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

    &format_subsetsC($fig,$cgi,$html,$subsystem);
    &format_subsetsR($fig,$cgi,$html,$subsystem);
}

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

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

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

    my @subset_names = $subsystem->get_subset_namesC;
    if (@subset_names > 1)
    {
	my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );

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

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

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

    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @tmp = grep { $_ ne "All" } sort $subsystem->get_subset_namesR;
    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,$subsystem,$tab,$nP) = @_;
    my($nameCS);

    foreach $nameCS (sort $subsystem->get_subset_namesC)
    {
	&format_subsetC($cgi,$html,$subsystem,$tab,$$nP,$nameCS);
	$$nP++;
    }
}

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

    if ($nameCS ne "All")
    {
	my $subset = $nameCS ? join(",",map { $subsystem->get_role_index($_) + 1 } $subsystem->get_subsetC($nameCS)) : "";
	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 tree_link {
    my $target = "window$$";
    my $url = &FIG::cgi_url . "/subsys.cgi?request=show_tree";
    return "<a href=$url target=$target>Show Phylogenetic Tree</a>";
}

sub format_rows {
    my($fig,$cgi,$html,$subsystem) = @_;
    my($i,%alternatives);

    my $ignore_alt = $cgi->param('ignore_alt');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);
    my %activeR = map { $_ => 1 } @subsetR;

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

    my @in = $subsystem->get_genomes;

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

	my @row_guide = ();

	my($role,%in_col);
	foreach $role (grep { $activeC{$_} } $subsystem->get_roles)
	{
	    if (! $in_col{$role})
	    {
		if ($_ = $alternatives{$role})
		{
		    my($abbrev,$mem) = @$_;
		    push(@$col_hdrs,$abbrev);
		    push(@row_guide,[map { [$_,"-" . ($subsystem->get_role_index($_) + 1)] } @$mem]);
		    foreach $_ (@$mem) { $in_col{$_} = 1 };
		}
		else
		{
		    push(@$col_hdrs,$subsystem->get_role_abbr($subsystem->get_role_index($role)));
		    push(@row_guide,[[$role,""]]);
		}
	    }
	}

	my $tab = [];
	my($genome,@pegs,@cells,$set,$peg_set,$pair,$role,$suffix,$row,$peg,$color_of,$cell,%count,$color,@colors);
	foreach $genome (grep { $activeR{$_} } @in)
	{
	    $row = [$genome, &ext_genus_species($fig,$genome),$subsystem->get_variant_code($subsystem->get_genome_index($genome))];

	    @pegs = ();
	    @cells = ();
	    foreach $set (@row_guide)
	    {
		$peg_set = [];
		foreach $pair (@$set)
		{
		    ($role,$suffix) = @$pair;
		    foreach $peg ($subsystem->get_pegs_from_cell($genome,$role))
		    {
			push(@$peg_set,[$peg,$suffix]);
		    }
		}
		push(@pegs,map { $_->[0] } @$peg_set);
		push(@cells,$peg_set);
	    }
	    $color_of = &group_by_clusters($fig,\@pegs);
	    foreach $cell (@cells)
	    {
		undef %count;
		foreach $_ (@$cell)
		{
		    if (($color = $color_of->{$_->[0]}) ne '#FFFFFF')
		    {
			$count{$color}++;
		    }
		}
		@colors = sort { $count{$b} <=> $count{$a} } keys(%count);
		$color = (@colors > 0) ? $colors[0] : '#FFFFFF';
		push(@$row,"\@bgcolor=\"$color\":" . join(", ",map { &HTML::fid_link($cgi,$_->[0],"local") . $_->[1] } @$cell));
	    }
	    push(@$tab,$row);
	}


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

	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 group_by_clusters {
    my($fig,$pegs) = @_;
    my($peg,@clusters,@cluster,@colors,$color,%seen,%conn,$x,$peg1,@pegs,$i);

    my $color_of = {};
    foreach $peg (@$pegs) { $color_of->{$peg} = '#FFFFFF' }

    if ($cgi->param('show_clusters'))
    {
	@pegs = keys(%$color_of);

	foreach $peg (@pegs)
	{
	    foreach $peg1 (grep { $color_of->{$_} && ($_ 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]);
	    }
	}

	@colors = 
	    (
	     '#C0C0C0',
	     '#FF40C0',
	     '#FF8040',
	     '#FF0080',
	     '#FFC040',
	     '#40C0FF',
	     '#40FFC0',
	     '#C08080',
	     '#C0FF00',
	     '#00FF80',
	     '#00C040'
	    );

	@clusters = grep { @$_ > 1 } sort { @$a <=> @$b } @clusters;

	if (@clusters > @colors) { splice(@clusters,0,(@clusters - @colors)) }  # make sure we have enough colors

	my($cluster);
	foreach $cluster (@clusters)
	{
	    $color = shift @colors;
	    foreach $peg (@$cluster)
	    {
		$color_of->{$peg} = $color;
	    }
	}
    }
    return $color_of;
}

sub format_ssa_table {
    my($cgi,$html,$user,$ssaP) = @_;
    my($ssa,$curator);
    my($url1,$link1);

    my $can_alter = $cgi->param('can_alter');
    push(@$html, $cgi->start_form(-action => "subsys.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)
    {
	my($publish_checkbox);
	($ssa,$curator) = @$_;

	my($url,$link);
	if ((-d "$FIG_Config::data/Subsystems/$ssa/Backup") && ($curator eq $cgi->param('user')))
	{
	    $url = &FIG::cgi_url . "/subsys.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 . "/subsys.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 . "/subsys.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 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 sort { $a->[0] cmp $b->[0] } @ssa;
}

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 . "/subsys.cgi?user=$user&ssa_name=$ssa&request=show_ssa&can_alter=$can_alter";
    return "<a href=$url target=$target>$name</a>";
}

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 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,$subsystem) = @_;
    my($org,$abr,$role,$missing);

    $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
    my($set,$col,%in);
    foreach $set (@alt_sets) 
    {
	my @mem = grep { $activeC{$_} } $subsystem->get_subsetC($set);
	foreach $col (@mem)
	{
	    $in{$col} = $set;
	}
    }
    push(@$html,$cgi->h1('To Check Missing Entries:'));

    foreach $org (@subsetR)
    {
	my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);

	$missing = [];
	foreach $role (@missing)
	{
	    $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role));
	    my $roleE = $cgi->escape($role);
	    
	    my $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)
	{
	    my $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));
	    push(@$html,$cgi->ul($cgi->li($missing)));
	}
    }
}

sub columns_missing_entries {
    my($cgi,$subsystem,$org,$roles,$in) = @_;

    next if (($_ = $cgi->param('just_genome')) && ($org != $_));
    my $just_col = $cgi->param('just_col');
    my(@really_missing) = ();

    my($role,%missing_cols);
    foreach $role (@$roles)
    {
	next if ($just_col && ($role ne $just_col));
	if ($subsystem->get_pegs_from_cell($org,$role) == 0)
	{
	    $missing_cols{$role} = 1;
	}
    }

    foreach $role (@$roles)
    {
	if ($missing_cols{$role})
	{
	    my($set);
	    if (($set = $in->{$role}) && (! $cgi->param('ignore_alt')))
	    {
		my @set = $subsystem->get_subsetS($set);

		my($k);
		for ($k=0; ($k < @set) && $missing_cols{$set[$k]}; $k++) {}
		if ($k == @set)
		{
		    push(@really_missing,$role);
		}
	    }
	    else
	    {
		push(@really_missing,$role);
	    }
	}
    }
    return @really_missing;
}

sub format_missing_including_matches 
{
    my($fig,$cgi,$html,$subsystem) = @_;
    my($org,$abr,$role,$missing);

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

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    my @alt_sets = grep { ($_ =~ /^\*/) } $subsystem->get_subset_namesC;
    my($set,$col,%in);
    foreach $set (@alt_sets) 
    {
	my @mem = grep { $activeC{$_} } $subsystem->get_subsetC($set);
	foreach $col (@mem)
	{
	    $in{$col} = $set;
	}
    }
    push(@$html,$cgi->h1('To Check Missing Entries:'));

    push(@$html, $cgi->start_form(-action=> "fid_checked.cgi"));

    my $can_alter = $cgi->param('can_alter');
    push(@$html,
	 $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	 $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1));
    
    foreach $org (@subsetR)
    {
	my @missing = &columns_missing_entries($cgi,$subsystem,$org,\@subsetC,\%in);
	$missing = [];

	foreach $role (@missing)
	{
	    next if (($_ = $cgi->param('just_role')) && ($_ != ($subsystem->get_role_index($role) + 1)));
	    $abr = $subsystem->get_role_abbr($subsystem->get_role_index($role));
	    my $roleE = $cgi->escape($role);
	    
		#
		# All the way up to 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);
	}

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

	if (@$missing > 0)
	{
	    my $colhdr = ["Assign", "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;

		my $my_peg_link = &HTML::fid_link($cgi, $my_peg, 1);
		my $match_peg_link = &HTML::fid_link($cgi, $match_peg, 0);

		my $checkbox = $cgi->checkbox(-name => "checked",
					      -value => "to=$my_peg,from=$match_peg",
					      -label => "");

		push(@$tbl, [$checkbox,
			     $psc,
			     $my_peg_link, $my_len, $my_fn,
			     $match_peg_link, $match_len, $match_fn]);
	    }

	    push(@$html, &HTML::make_table($colhdr, $tbl, ""));
	}
	else
	{
	    push(@$html, $cgi->p("No matches."));
	}
	   
    }
    push(@$html,
	 $cgi->submit(-value => "Process assignments",
			      -name => "batch_assign"),
	 $cgi->end_form);
}

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

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

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

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

    my($org,$duplicates,$role,$genus_species);
    foreach $org (@subsetR)
    {
	$duplicates = [];
	foreach $role (@subsetC)
	{
	    my(@pegs,$peg,$func);
	    if ((@pegs = $subsystem->get_pegs_from_cell($org,$role)) > 1)
	    {
		push(@$duplicates,"$role<br>" . $cgi->ul($cgi->li([map { $peg = $_; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } @pegs])));
	    }
	}

	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_coupled {
    my($fig,$cgi,$html,$subsystem,$type) = @_;
    my($i,$j,@show,$user,$org,$link,$gs,$func,$peg,$peg1,$peg2,%in,%seen,%seen2);
    my(@cluster,$sc,$x,$id2,@in,$sim,@coupled);
    my($org,$role);

    $user = $cgi->param('user');

    my $active_subsetC = ($cgi->param('active_subsetC') or $subsystem->get_active_subsetC );
    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );

    my @subsetC = $subsystem->get_subsetC($active_subsetC);
    my %activeC = map { $_ => 1 } @subsetC;

    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    foreach $org (@subsetR)
    {
	foreach $role (@subsetC)
	{
	    push(@in,$subsystem->get_pegs_from_cell($org,$role));
	}
    }

    %in = map { $_ => 1 } @in;
    @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,$subsystem) = @_;
    my($colN,@checked,$cutoff);

    my $checked;
    my $roles = [$subsystem->get_roles];
    if (($colN = &which_column($col,$roles)) &&
	((@checked = &seqs_to_align($colN,$subsystem)) > 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 -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");
    }
}

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

    if (($col =~ /^(\d+)/) && ($1 <= @$roles))
    {
	return $roles->[$1-1];
    }
    return undef;
}

sub seqs_to_align {
    my($role,$subsystem) = @_;
    my($genome);

    my $active_subsetR = ($cgi->param('active_subsetR') or $subsystem->get_active_subsetR );
    my @subsetR = $subsystem->get_subsetR($active_subsetR);

    my @seqs = ();
    foreach $genome (@subsetR)
    {
	push(@seqs,$subsystem->get_pegs_from_cell($genome,$role));
    }
    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 . "/subsys.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");
	}
	&reset_peg_subsystem_connections($fig,$ssa);  # you must break and restore connections of pegs to subsystem
	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