[Bio] / RegSubMa / SVSubsystem.pm Repository:
ViewVC logotype

View of /RegSubMa/SVSubsystem.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (download) (as text) (annotate) (vendor branch)
Wed Apr 4 17:08:51 2007 UTC (13 years, 2 months ago) by mkubal
Branch: MAIN, fig
CVS Tags: v_1_0_0, HEAD
Changes since 1.1: +0 -0 lines
initial checkin

package SVSubsystem;

use strict;
use warnings;

use FIG;
use UnvSubsys;
use Subsystem; 
use MIME::Base64;
use GD;

use SeedViewer;
use Table;

our @ISA = qw( Exporter );
our @EXPORT = qw ( get_subsystem_by_name 
                    get_subsystem_floating_box
		    get_subsystem_roles
		    get_subsystem_role_subsets 
		    get_subsystem_title 
		    get_subsystem_diagrams 
		    get_subsystem_notes
                    get_subsystem_spreadsheet
		  );

# global variables ftw!
my %ec2id=();
my %ec2gofunc=();

use constant GO_URL => 'http://www.godatabase.org/cgi-bin/amigo/go.cgi'.
                       '?action=query&view=query&search_constraint=terms&query=';
use constant REACTION_URL => 'http://www.genome.ad.jp/dbget-bin/www_bget?rn+';


1;


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

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

  return undef unless (defined $ssa);

  my $subsystem = new UnvSubsys($ssa,
				$fig,
				$active_subsetR,
				$focus,
				$colors,
				'',
				$specific_pegs_to_color);
  
  if (ref $subsystem) {
    
    # load the EC mapping 
    open (IN,"$FIG_Config::data/Global/ec2go") or warn $!;
    while ($_ = <IN>) {
      chomp;
      $_ =~ /EC:([0-9\-\.]+)\s+\>\s+GO:\s*(\S.*\S)\s*\;\s+GO:(\d+)$/;
      my ($ec,$func,$id) = ($1,$2,$3);
      $ec2id{$ec}=$id;
      $ec2gofunc{$ec}=$func;
    }
    close (IN);

    return $subsystem;
  }

  return undef;

}

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

  # subsystem name and curator
  my $html = '<h1>Subsystem: '.$subsystem->get_ssa_pretty.'</h1>';
  $html .= '<table><tr><th>Author:</th><td>'.$subsystem->subsystem_curator.'</td></tr></table>';

  return $html;
}


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

  my $ssa = $subsystem->get_ssa_pretty;
  my $roles_total = scalar( $subsystem->get_roles );
  my $genomes_total = scalar( $subsystem->get_genomes );
  my $diagrams_total = scalar( $subsystem->get_diagrams );

  my $variant_pos = 0;
  my $variant_neg = 0;
  my $variant_zero = 0;

  foreach my $genome ($subsystem->get_genomes) {
    my $code = $subsystem->get_variant_code( $subsystem->get_genome_index( $genome ) );
    if ($code > 0) {
      $variant_pos++;
    }
    elsif ($code < 0) {
      $variant_neg++;
    }
    elsif ($code == 0) {
      $variant_zero++;
    }
  }

  my $stats = qq~<table>
<tr><td colspan="2">$ssa</td></tr>
<tr><td colspan="2"><hr/></td></tr>
<tr><td>No. of functional roles:</td><td>$roles_total</td></tr>
<tr><td>No. of genomes:</td><td>$genomes_total</td></tr>
<tr><td colspan="2"><hr/></td></tr>
<tr><td colspan="2">Of those genomes the following have been classified as ..</td></tr>
<tr><td>present:</td><td>$variant_pos</td></tr>
<tr><td>not present:</td><td>$variant_neg</td></tr>
<tr><td>work in progress:</td><td>$variant_zero</td></tr>
</table>
~;

  my $boxes = [ { color => 'brown', title => "Subsystem Overview", content => $stats }, ];

  return $boxes;

}


sub get_subsystem_roles {
  my ($fig, $cgi, $subsystem) = @_;
  
  # subsystem roles and reactions
  my @roles = $subsystem->get_roles;
  my $reactions = $subsystem->get_reactions;
  
  # functional roles
  my $roles = [];
  foreach my $role_name (@roles) {
    my $role = {};
    
    # get abbrev and name
    $role->{'abbrev'} = $role_name ? $subsystem->get_role_abbr($role_name) : "";
    $role->{'funct_role'} = $role_name;
    $role->{'funct_role_name'} = $role_name;

    # get group alias
    foreach my $nameCS (sort $subsystem->get_subset_namesC) {
      if (defined $nameCS and $nameCS =~ /^\*.+$/) {
	
	foreach ($subsystem->get_subsetC_roles($nameCS)) {
	  next unless ($_ eq $role_name);
	  $role->{'group_alias'} = $nameCS;
	}
      }
    }

    # get reaction links
    $role->{'reactions'} = [];
    if ($reactions->{$role_name} and scalar(@{$reactions->{$role_name}})) {
      $role->{'reaction_links'} = [];
      foreach (@{$reactions->{$role_name}}) {
	push @{$role->{'reactions'}}, $_;
	if ($_ =~ /^R\d+/) {
	  push @{$role->{'reaction_links'}}, '<a href="'.REACTION_URL.qq~$_" target="reaction">$_</a>~;
	}
      }
      $role->{'reaction_link'} = '<a href="index.cgi?action=ShowFunctionalRole&subsystem_name='.
	$subsystem->get_ssa.'&role_name='.$role_name.'">'.
	'<img height="22" src="./Html/seed-icon-react-av.png" title="'.
	  scalar(@{$reactions->{$role_name}}).' reaction(s) found."/></a>';
    }
    else {
      $role->{'reaction_link'} = '<img height="22" src="./Html/seed-icon-react-na.png" title="No reactions available."/>';
    }
    
    # get EC number
    my ($ec) = ($role_name =~ /EC\s([0-9\-\.]+)/);
    if ($ec) {
      $role->{'EC'} = qq~<a href="http://www.genome.jp/dbget-bin/www_bget?ec:$ec" target="outbound">$ec</a>~;
      $role->{'EC_link'} = qq~<a href="http://www.genome.jp/dbget-bin/www_bget?ec:$ec" target="outbound">~.
	qq~<img height="22" src="./Html/seed-icon-ec-av.png" title="EC $ec"/></a>~;
    }
    else {
      $role->{'EC'} = '';
      $role->{'EC_link'} = '<img height="22" src="./Html/seed-icon-ec-na.png" title="No EC number available."/>';
    }
    # $role->{'funct_role_name'} =~ s/\(EC $ec\)// if ($ec);

    # get GO information
    if (defined $ec and exists $ec2id{$ec} and $ec2id{$ec} ne "") {
      $role->{'GO'} = $ec2id{$ec};
      $role->{'GO_desc'} = "$ec2gofunc{$ec} \(".$role->{'GO'}."\)";
      $role->{'GO_link'} = '<a href="'.GO_URL.$role->{'GO'}.'" target="outbound">'.
	'<img height="22" src="./Html/seed-icon-go-av.png" title="'.$role->{'GO_desc'}.'"/></a>';
    }
    else {
      $role->{'GO_desc'} = 'unknown';
      $role->{'GO_link'} = '<img height="22" src="./Html/seed-icon-go-na.png" title="No GO term available."/>';
    }
    push @$roles, $role;
  }
  
  # get (true) subsystem role subsets 
  my $subsets = {};
  foreach my $nameCS (sort $subsystem->get_subset_namesC) {
    if (defined $nameCS and $nameCS ne "" and 
	$nameCS !~ /all/i and $nameCS !~ /^\*.+$/) {
      my $role_ids = join(",",map { $subsystem->get_role_index($_) } 
			  $subsystem->get_subsetC_roles($nameCS));   
      $subsets->{$role_ids} = $nameCS;
    }
  }
  
  # subset select box
  my $subset_select = '';
  if (scalar(keys(%$subsets))) {
    my $values = [ 'none' ];
    push @$values, keys(%$subsets);
    $subset_select .= '<p> Highlight subsets: '.$cgi->popup_menu( -id    => 'subset_select',
								  -values  => $values,
								  -default => 'none',
								  -labels  => $subsets,
								  -onChange => "highlight_subset()"
								).'</p>';
  }

  # fill html
  my $html .= '<div><h2>Functional Roles ('.$subsystem->get_ssa_pretty.')</h2>'.$subset_select;

  if (scalar(@$roles)) {

    my $table_params = { data => [],
			 popup_menu => { infos => [], titles => [], },
			 columns => [ 'Group Alias', 'Abbrev', 'Functional Role', 'EC', 'Ontologies' ],
			 id => 'roles',
			 column_widths => [ undef, undef, 450 ],
		       };
    
    for (my $i=0; $i < scalar(@$roles); $i++) {

      my $row_info = [];
      my $tt_ec = ($roles->[$i]->{'EC'}) ? $roles->[$i]->{'EC'} : 'unknown';
      my $tt_rc = (scalar(@{$roles->[$i]->{'reactions'}})) ? join(', ',@{$roles->[$i]->{'reactions'}}) : 'unknown';
      push @$row_info, '', '', '<table><tr><td colspan="2">'.$roles->[$i]->{'funct_role_name'}.'</td></tr>'.
	'<tr><th>EC:</th><td>'.$tt_ec.'</td></tr>'.
	'<tr><th>GO number:</th><td>'.$roles->[$i]->{'GO_desc'}.'</td></tr>'.
	'<tr><th>Reaction(s):</th><td>'.$tt_rc.'</td></tr>'.'</table>', '', '';
      my $row_titles = [];
      push @$row_titles, '', '', 'Functional Role', '', '';
      push @{$table_params->{popup_menu}->{infos}}, $row_info;
      push @{$table_params->{popup_menu}->{titles}}, $row_titles;

      my $row = [];
      push @$row, $roles->[$i]->{'group_alias'};
      push @$row, $roles->[$i]->{'abbrev'};
      push @$row, '<a href="index.cgi?action=ShowFunctionalRole&subsystem_name='.
	$subsystem->get_ssa.'&role_name='.$roles->[$i]->{'funct_role'}.'">'.$roles->[$i]->{'funct_role_name'}.'</a>';
      push @$row, $roles->[$i]->{'EC'};
      push @$row, '<span style="white-space:nowrap;">'.$roles->[$i]->{'EC_link'}.
	$roles->[$i]->{'reaction_link'}.$roles->[$i]->{'GO_link'}.'</span>';
      
      push @{$table_params->{data}}, $row;
    }
  
    $html .= &Table::new($table_params);
  }
  else {
    $html .= "<p><strong>No functional roles have been defined for this subsystem. Likely, this is a proposed subsystem.</strong></p>";
  }

  return $html."</div>";
}


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

  my $table_params = { data => [],
		       columns => [ 'Subset', 'Includes these functional roles' ],
		       id => 'subset',
		     };

  foreach my $nameCS (sort $subsystem->get_subset_namesC) {
    if (defined $nameCS and $nameCS ne "" and $nameCS !~ /all/i) {
      my $subset = join(", ",map { $subsystem->get_role_abbr($_) } $subsystem->get_subsetC_roles($nameCS));      
      push(@{$table_params->{data}}, [ $nameCS, $subset ]);
    }
  }
  
  if (scalar(@{$table_params->{data}})) {
    return '<div>'.&Table::new($table_params).'</div>';
  }
  return '';
  
}


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

  my $html = '';

  my @diagrams = $subsystem->get_diagrams();
  if (scalar(@diagrams)) {
    
    $html .= '<div><h2>Subsystem Diagram(s):</h2>';
    
    my $values = [];
    my $labels = {};
    my $default = '';
    my $images = '';
    my $first = 1;

    foreach (sort { $a->[0] cmp $b->[0] } @diagrams) {
      my ($id, $name, $plink, $img_link) = @$_; 

      # UnvSubsys has no access to diagram images, get a Subsystem instead
      my $sub = $fig->get_subsystem($subsystem->get_ssa);

      # get diagram type and file handle
      my ($type, $fh) = $sub->open_diagram_image($id);
      $type or die "Unknown diagram image type.\n";
      
      # create inline image
      my $img = GD::Image->new($fh);
      
      if ($img) {

	# get select box data
	push @$values, $id;
	$labels->{$id} = $name;
	$default = $id if ($first);

	# update images
	my $encoded = MIME::Base64::encode($img->png());
	my $class = ($first) ? 'showme' : 'hideme';
	$images .= qq~<img id="diagram-$id" class="$class" name="diagrams" src="data:image/gif;base64,$encoded"/>~;
	
	$first = 0;

      }
    }

    # select box
    if (scalar(@$values)>1) {
      $html .= '<p> Browse available diagrams: '.$cgi->popup_menu( -id    => 'diagrams_select',
								   -values  => $values,
								   -default => $default,
								   -labels  => $labels,
								   -onChange => "show_image()"
								 ).'</p>';
    }
    $html .= '<p>'.$images.'</p>';
    $html .= '</div>';
    
  }     
  
  return $html;
}

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

  my $notes = $subsystem->get_notes();
  $notes =~ s/\n\s*\n/\n\n/g; # this just removes many empty lines (e.g. "\n \n \n \n" matches this regexp)
  
  if ($notes =~ /\w+/) {
    $notes =~ s/(.{0,80}\s)/$1\n/g; # pre width=80 doesn't work at least in safari. This works.
    return "<div><h2>Notes:</h2><p><pre>$notes</pre></p></div>";
  }
  else {
    return "<div><h2>No notes available.</h2></div>";
  }
}



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

  # get all genomes which are present in this subsystem
  my @genomes = $subsystem->get_genomes;

  # check if only a genome subset should be displayed (active_subsetR)
  if (defined $cgi->param('active_subsetR') and $cgi->param('active_subsetR') ne 'All') {
    @genomes = $subsystem->get_subsetR($cgi->param('active_subsetR'));
  }

  # mapping role to group alias
  my $role2group = {};
  foreach my $subset (sort $subsystem->get_subset_namesC) {
    if (defined $subset and $subset =~ /^\*.+$/) {
      foreach ($subsystem->get_subsetC_roles($subset)) {
	$role2group->{ $subsystem->get_role_abbr($_) } = $subset;
      }
    }
  }

  # collect indexes of columns (roles) that belong to a group
  my $groups = {};
  my @roles = $subsystem->get_roles;
  for (my $r = 0; $r < scalar(@roles); $r++) {
    if (exists( $role2group->{ $roles[$r] } )) {
      $groups->{ $role2group->{ $roles[$r] } } = []
	unless (exists( $groups->{ $role2group->{ $roles[$r] } } ));
      push @{ $groups->{ $role2group->{ $roles[$r] } } }, $r;
    }
  }

  my $data = [];
  foreach my $genome (@genomes) {
    my $entry = {};

    $entry->{id} = $genome;
    $entry->{variant} = $subsystem->get_variant_code( $subsystem->get_genome_index( $genome ) );
    $entry->{genus_species} = $fig->genus_species($genome);
    $entry->{full_name} = $entry->{genus_species}.' ['.substr($fig->taxonomy_of($genome),0,1).']';
    $entry->{max_clusters} = 0;
    $entry->{role_abbrev}  = [];
    $entry->{role_members} = [];

    # get pegs for each role in that row
    my $pegs = [];
    my $groups_done = {};
    foreach my $role ($subsystem->get_roles) {

      if (defined $cgi->param('subset_select') and ($cgi->param('subset_select') ne 'none')) {
	my @roles = $subsystem->get_subsetC_roles($cgi->param('subset_select'));
	my $show = 0;
	for (my $c=0; $c < scalar(@roles); $c++) {
	  if ($role eq $roles[$c]) {
	    $show = 1;
	    last;
	  }
	}
	next unless ($show);
      }

      # get role abbr and init members array
      my $abbr = $subsystem->get_role_abbr($role);
      my @pegs;

      # by default collapse groups
      my $group = (exists($role2group->{$abbr})) ? $role2group->{$abbr} : '';
      if (!$cgi->{'expand_groups'} and $group) {

	# if it's already done skip it
	next if (exists($groups_done->{$group}));

	$abbr = $group;
	foreach ($subsystem->get_subsetC_roles($group)) {
	  push @pegs, $subsystem->get_pegs_from_cell($genome,$_);
	  $groups_done->{$group} = 1;
	}
      }
      else {
	@pegs = $subsystem->get_pegs_from_cell($genome,$role);
      }

      # set column name (role) 
      push @{$entry->{role_abbrev}}, $abbr;

      # retain an original array of pegs to fetch the cluster 
      push @$pegs, @pegs;

      # transform it into array of arrays to store the cluster info
      for (my $i = 0; $i < scalar(@pegs); $i++) {
	$pegs[$i] = [ $pegs[$i], 0];
      }
      
      # set role members
      push @{$entry->{role_members}}, \@pegs;
    }
    
    # get clusters for that row
    my @clusters = $fig->compute_clusters($pegs, $subsystem);
    $entry->{clusters} = \@clusters;
    for (my $j = 0; $j < scalar(@clusters); $j++) {
      foreach my $clusterpeg (@{$clusters[$j]}) {
     	foreach my $role (@{$entry->{role_members}}) {
	  foreach my $peg (@$role) {
	    $peg->[1] = $j+1 if ($clusterpeg eq $peg->[0]);
	    $entry->{max_clusters} = $j+1 if ($j+1 > $entry->{max_clusters});
	  }
	}
      }
    }
    
    push @$data, $entry;
  }

  # help link
  my $help .= &create_help_link({ string    => '',
			       # readable source code ends here
			       text      => '<p><strong>What do you see inside a spreadsheet cell:</strong><br/> The genes within a genome that take a specific functional role (the content of one cell) are represented by different icons. Clustered genes are represented by small colored squares. The colors differentiate between the 1st through 5th identified cluster for that genome.</p><p><table><tr><td><img src=&quot;./Html/seed-icon-spreadsheet-1.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-2.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-3.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-4.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-5.png&quot;/></td></tr><tr><td colspan=5>a single CDS that is member of a cluster</td></tr><tr><td><img src=&quot;./Html/seed-icon-spreadsheet-1+.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-2+.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-3+.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-4+.png&quot;/></td><td><img src=&quot;./Html/seed-icon-spreadsheet-5+.png&quot;/></td></tr><tr><td colspan=5>multiple CDS that are member of a cluster</td></tr></table></p>',
			     # ..
			       help_page => 'Subsystem',
			     } );

  # fill html
  my $html .= '<div><h2>Populated Subsystem ('.$subsystem->get_ssa_pretty.')'.$help.'</h2>';
  
  if (scalar(@$data)) {

    # count how many rows are actually displayed
    my $count = 0;

    my $table_params = { data => [],
			 columns => [ 'Organism', 'Variant' ],
			 id => 'pss',
			 sortable => 1,
			 perpage => 10,
			 highlights => [],
			 column_widths => [220, 60],
			 show_topbrowse => 1,
			 show_bottombrowse => 1,
			 operands => { 'Organism' => '' },
		       };
    
    # add one column per role (row) or group alias
    foreach (@{$data->[0]->{role_abbrev}}) {
      push @{$table_params->{columns}}, &draw_column_headers($_); 
    }
    
    # fill in the data for one row
    for (my $i=0; $i < scalar(@$data); $i++) {
      
      # negative variant codes are usually not shown
      # to show them set cgi parameter 'show_neg_variants' to true
      next if ($data->[$i]->{'variant'} < 0 and !$cgi->param('show_neg_variants'));

      # zero variant codes are usually not shown
      # to show them set cgi parameter 'show_zero_variants' to true
      next if ($data->[$i]->{'variant'} == 0 and !$cgi->param('show_zero_variants'));
      
      # highlight row by genome id
      my $highlight_row = [];
      foreach (@{$table_params->{columns}}) {
	if (defined $cgi->param('focus') and $cgi->param('focus') eq $data->[$i]->{'id'}) {
	  push @$highlight_row, 1;
	}
	else {
	  push @$highlight_row, 0;
	}
      }
      push @{$table_params->{highlights}}, $highlight_row;
      
      my $row = [];
      
      # genome/organism name - truncate full name and add tooltip
      my $id = '<a href="index.cgi?action=ShowOrganism&genome='.$data->[$i]->{'id'}.'">'.$data->[$i]->{'id'}.'</a>';
      my $name = $data->[$i]->{'full_name'};
      my $tt_name = '';
      if (length($data->[$i]->{'full_name'}) > 27) {
	$name = substr($data->[$i]->{'full_name'}, 0, 27).'...';
	$tt_name = qq~onMouseover="javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Genome', '~.
	  $data->[$i]->{'full_name'}.qq~', ''); this.tooltip.addHandler(); return false;"~;
      }
      push @$row, "<span $tt_name>$name<br/>$id</span>";
      
      # variant code
      push @$row, $data->[$i]->{'variant'};
      
      # fill in the pegs for each role
      foreach my $pegs (@{$data->[$i]->{role_members}}) {
	my $cell = &draw_cell_icon($pegs, $data->[$i]->{max_clusters});
	push @$row, $cell;
      }
      
      push @{$table_params->{column_widths}}, 28;
      push @{$table_params->{data}}, $row;
      $count++;
    }
    
    if ($count) {
      $html .= &Table::new($table_params);
    }
    else {
      $html .= '<p><em>No genomes match the current criteria.</em></p>';
    }

    # get (true) subsystem role subsets 
    my $subsets = [];
    foreach my $nameCS (sort $subsystem->get_subset_namesC) {
      if (defined $nameCS and $nameCS ne "" and 
	  $nameCS !~ /all/i and $nameCS !~ /^\*.+$/) {
	push @$subsets, $nameCS;
      }
    }

    # get taxonomy (genome) subsets
    my @taxon_subset = $subsystem->get_subsetsR();
    @taxon_subset = sort { if ($a eq 'All') { return -1; }
			   elsif ($b eq 'All') { return 1; }
			   else { return $a cmp $b; } } map { $_->[0] } @taxon_subset;

    # start form
    $html .= $cgi->start_form( -method => 'POST',
			       -action => $cgi->url(-relative => 1) );
    $html .= $cgi->hidden('action', $cgi->param('action'));
    $html .= $cgi->hidden('subsystem_name', $cgi->param('subsystem_name'));
    $html .= $cgi->hidden('display', 'populated');

    # subset select box
#     if (scalar(@$subsets)) {
#       my $values = ['none'];
#       push @$values, @$subsets;
#       $html .= '<p>Collapse columns by subset: '.$cgi->popup_menu( -name    => 'subset_select',
# 								   -values  => $values,
# 								 ).'</p>';
#     }
    
    $html .= '<p>Limit genomes by taxonomy: '.$cgi->popup_menu( -name    => 'active_subsetR',
								-values  => \@taxon_subset,
								-default => 'All',
							      ).'</p>';

    if (scalar(keys(%$groups))) {
      $html .= '<p>'.$cgi->checkbox( -name    => 'expand_groups',
				     -checked => 0,
				     -value   => 1,
				     -label   => 'Expand columns with equivalent functional roles (Group aliases, marked with *)').'</p>';
    }
    $html .= '<p>'.$cgi->checkbox( -name    => 'show_neg_variants',
				   -checked => 0,
				   -value   => 1,
				   -label   => 'Show organisms classified as not present in this subsystem').'</p>';
    $html .= '<p>'.$cgi->checkbox( -name    => 'show_zero_variants',
				   -checked => 0,
				   -value   => 1,
				   -label   => 'Show organisms classified as work in progress').'</p>';
    $html .= '<p>'.$cgi->submit(-name => 'Refresh populated subsystem').'</p>';

    $html .= $cgi->end_form();
  }    
  else {
    $html .= "<p><strong>This subsystem has not yet been populated.</strong></p>";
  }
  
  $html .= "</div>";

  return $html;

}


sub draw_cell_icon {
  my ($pegs, $max_clusters) = @_;

  my $css = 'style="margin-bottom: 1px;"';
 
  my $unclustered = 0;
  my $too_many_clusters = 0;
  my $cluster_icons = {};

  my $tt_text = '';
  my $tt_menu = '';
  foreach my $peg (sort { if($a->[1] == 0) { return 1; }
			  elsif($b->[1] == 0) { return -1; }
			  else { return $a->[1] <=> $b->[1]; } } @$pegs) {

    # if clustered, include icon
    if ($peg->[1]) {
      
      # check if we have too many clusters for that genome
      if ($peg->[1] > 5) {
	$too_many_clusters++;
      }
      else {
	# check that we havent drawn that cluster before
	if (!exists( $cluster_icons->{$peg->[1]} )) {
	  $cluster_icons->{$peg->[1]} = '<img '.$css.' src="./Html/seed-icon-spreadsheet-'.$peg->[1].'.png"/><br/>';
	}
	
	# add icon for multiple members instead
	else {
	  $cluster_icons->{$peg->[1]} = '<img '.$css.' src="./Html/seed-icon-spreadsheet-'.$peg->[1].'+.png"/><br/>';
	}
      }
    }
    
    # count unclustered pegs
    else {
      $unclustered++;
    }

    # tooltip text and menu (basically the same, just the menu version has links)
    my $cluster_no = ($peg->[1]) ? $peg->[1].': ' : '';
    $tt_text .= ( exists($cluster_icons->{$peg->[1]}) ) 
        ? qq~<img src=./Html/seed-icon-spreadsheet-~.$peg->[1].qq~.png> $cluster_no~.$peg->[0].qq~<br/> ~
	: qq~<img src=./Html/seed-icon-spreadsheet-none.png> $cluster_no~.$peg->[0].qq~<br/> ~;
    $tt_menu .= ( exists($cluster_icons->{$peg->[1]}) ) 
        ? qq~<img src=./Html/seed-icon-spreadsheet-~.$peg->[1].qq~.png>~
	: qq~<img src=./Html/seed-icon-spreadsheet-none.png>~;
      
    $tt_menu .= qq~<a href=index.cgi?action=ShowAnnotation&prot=~.$peg->[0].qq~>$cluster_no~.$peg->[0].qq~</a><br/> ~;

  }
  
  # fill html - begin by stacking icons
  my $icons = '';
  for (my $i = 1; $i <= 5; $i++) {
    if (exists( $cluster_icons->{$i} )) {
      $icons .= $cluster_icons->{$i};
    }
    else {
      if ($max_clusters >= $i) {
	$icons .= '<img '.$css.' src="./Html/seed-icon-spreadsheet-none.png"/><br/>';
      }
    }
  }

  if ($too_many_clusters) {
    $icons .= '<img '.$css.' src="./Html/seed-icon-spreadsheet-more.png"/><br/>';
  }

  # create icon subtext
  my $subtext = ($unclustered) ? qq~<span style="font-size: 9px; width: 20px; display: block; text-align: center; color: #000; border: 1px solid #000"><strong>$unclustered</strong></span>~ : '';

  # create tooltip
  my $tooltip = qq~onMouseover="javascript:if(!this.tooltip) this.tooltip=new Popup_Tooltip(this, 'Coding Sequences', '$tt_text', '$tt_menu'); this.tooltip.addHandler(); return false;"~;
  
  # add css style to cell
  my $css_cell = 'style="margin: 0px; padding: 0px;"';

  return qq~<div $css_cell $tooltip>$icons $subtext</div>~;

}


sub draw_column_headers {
  my ($header) = @_;

  # create a new image
  my @chars = split(//,$header);
  my $height = scalar(@chars)*(gdGiantFont->width+1);
  my $image = new GD::Image(22,$height);
  
  # allocate some colors
  my $black = $image->colorResolve(0,0,0);   
  my $white = $image->colorResolve(255,255,255);

  # make the background transparent and interlaced
  $image->transparent($black);
  $image->interlaced('true');

  # write header string
  $image->stringUp(gdGiantFont, 2, $height-1, $header, $white);
  
  # base64 inline encode
  my $encoded = MIME::Base64::encode($image->png());
  return qq~<img src="data:image/gif;base64,$encoded"/>~;

}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3