lib/Bio/Graphics/Karyotype.pm

package Bio::Graphics::Karyotype;

# $Id$
# Utility class to create a display of a karyotype and a series of "hits" on the individual chromosomes
# Used for searching


use strict;
use Bio::Graphics::Panel;
use GD 'gdSmallFont';
use CGI qw(img div span b url table TR th td b escapeHTML a br);
use Carp 'croak';

# there is a bug in the ideogram glyph that causes a core dump when
# drawing small chromosomes - this "fixes" the problem
use constant SUPPRESS_SMALL_CHROMOSOMES => 50;  # suppress chromosomes smaller than 50 pixels

sub new {
  my $class = shift;
  my %args            = @_;
  my $source          = $args{source}   or croak "source argument mandatory";
  my $lang            = $args{language};
  return bless {
		source   => $source,
		language => $lang,
		},ref $class || $class;
}

sub db             { 
    my $self = shift;
    my $source = $self->data_source;
    my $db     = $source->karyotype_setting('database');
    return $db ? $source->open_database("$db:database") : $source->open_database();
}
sub data_source    { shift->{source}     }
sub language       { shift->{language}   }

sub trans       { 
  my $self = shift;
  my $lang = $self->language or return '';
  return $lang->tr(@_);
}

sub chrom_type  { 
    return shift->data_source->karyotype_setting('chromosome')   || 'chromosome';
}

sub chrom_width {
    return shift->data_source->karyotype_setting('chrom_width')  || 16;
}

sub chrom_height {
    return shift->data_source->karyotype_setting('chrom_height') || 140;
}

sub chrom_background {
    my $band_colors     = shift->data_source->karyotype_setting('bgcolor')
	|| 'gneg:white gpos25:gray gpos75:darkgray gpos100:black gvar:var stalk:#666666';
}

sub chrom_background_fallback {
    my $band_colors     = shift->data_source->karyotype_setting('bgfallback')
	|| 'yellow';
}

sub add_hits {
  my $self     = shift;
  my $features = shift;
  $self->{hits} ||= {};

  for my $f (@$features) {
    my $ref = $f->seq_id;
    push @{$self->{hits}{$ref}},$f;
    $self->{hit_count}++;
  }

}

sub hit_count { shift->{hit_count} }

sub seqid_order {
    my $self = shift;
    return $self->{seqid_order} if exists $self->{seqid_order};

    my @chromosomes   = $self->chromosomes;
    my $sort_sub      = $self->sort_sub || \&by_chromosome_name;
    my @sorted_chroms = sort $sort_sub @chromosomes;
    my $i             = 0;
    my %order         = map {$_->seq_id => $i++} @sorted_chroms;

    return $self->{seqid_order} = \%order;
}

sub hits {
  my $self   = shift;
  my $seq_id = shift;

  my $hits = $self->{hits} or return;
  defined $seq_id          or return map {@$_} values %{$hits};

  my $list   = $self->{hits}{$seq_id} or return;
  return @$list;
}

# to sort chromosomes into their proper left->right order
sub sort_sub {
  my $self = shift;
  my $d    = $self->{sort_sub};
  $self->{sort_sub} = shift if @_;
  $d;
}

sub to_html {
  my $self        = shift;
  my $terms2hilite = shift;

  my $sort_order = $self->seqid_order;  # returns a hash of {seqid=>index}

  my $source     = $self->data_source;
  my $panels     = $self->{panels} ||= $self->generate_panels or return;

  my $html;

  my $hit_count = $self->hit_count;
  my $message   = $self->language->tr('HIT_COUNT',$hit_count);
  $html        .= CGI::h2($message);

  my @panels;
  for my $seqid (
      sort {$sort_order->{$a} <=> $sort_order->{$b}} keys %$panels
      ) {

    my $panel  = $self->{panels}{$seqid}{panel};
    # workaround bug/coredump in ideogram glyph
    next if $panel->height < SUPPRESS_SMALL_CHROMOSOMES;

    my $url    = $source->generate_image($panel->gd);

    my $margin = Bio::Graphics::Panel->can('rotate') 
	         ? $self->chrom_height - $panel->gd->height
                 : 5;

    my $imagemap  = $self->image_map(scalar $panel->boxes,"${seqid}.");
    push @panels,
	div(
	    {-style=>"cursor:default;float:left;margin-top:${margin}px;margin-left:0.5em;margin-right;0.5em"},
	    div({-style=>'position:relative'},
		img({-src=>$url,-border=>0}),
		$imagemap
	    ),
	    div({-align=>'center'},b($seqid))
	);
  }
  my $bgcolor = $self->data_source->global_setting('overview bgcolor') || 'wheat:0.5';
  $html    .= div({-style=>"background-color:$bgcolor"},@panels);

  my $table = $self->hits_table($terms2hilite);

  return $html.br({-clear=>'all'}).$table;
}

# not really an imagemap, but actually a "rollover" map
sub image_map {
    my $self            = shift;
    my $boxes           = shift;

    my $chromosome = $self->chrom_type;

    my $divs = '';

    for (my $i=0; $i<@$boxes; $i++) {
	next if $boxes->[$i][0]->primary_tag eq $chromosome;

	my ($left,$top,$right,$bottom) =  @{$boxes->[$i]}[1,2,3,4];
	$left     -= 2;
	$top      -= 2;
	my $width  = $right-$left+3;
	my $height = $bottom-$top+3;
	
	my $name = $boxes->[$i][0]->display_name || "feature id #".$boxes->[$i][0]->primary_id;
	my $id   = $self->feature2id($boxes->[$i][0]);
	my $link = $self->feature2link($boxes->[$i][0]);
	$divs .= div({-class => 'nohilite',
		      -id    => "box_${id}",
		      -style => "z-index:10; top:${top}px; left:${left}px; width:${width}px; height:${height}px",
		      -title => $name,
		      -onMouseOver=>"k_hilite_feature(this,true)",
		      -onMouseOut =>"k_unhilite_feature(this)",
		      -onMouseDown=>"location.href='$link'",
		     },'&nbsp;'
	    )."\n";
    }
    return $divs;
}

sub feature2link {
    my $self    = shift;
    my $feature = shift;
    my $url      = url(-absolute=>1,-path_info=>1)."?name=";
    my $match_id = eval {$feature->primary_id};
    my $class    = eval {$feature->class};
    my $name     = $feature->display_name || '';
    my $fid      =  $match_id 
 	                && $match_id !~ /\w+:\w+\(/   # work around a bioperl bug
                               ? "id:$match_id"
 	           : $class    ? "$class:$name" 
 		   : $name;
    my $dbid  = $feature->gbrowse_dbid if $feature && $feature->can('gbrowse_dbid');
    $dbid   ||= '';
    return "$url$fid;dbid=$dbid";
}

sub by_chromosome_length ($$) {
  my ($a,$b) = @_;
  my $n1     = $a->length;
  my $n2     = $b->length;
  return $n1 <=> $n2;
}

sub by_chromosome_name ($$){
  my ($a,$b) = @_;
  my $n1     = $a->seq_id;
  my $n2     = $b->seq_id;

  if ($n1 =~ /^\d+$/    && $n2 =~ /^\d+$/) {
      return $n1 <=> $n2;
  }
  elsif ($n1 =~ /^\w+\d+$/ && $n2 =~ /^\w+\d+$/) {
    $n1 =~ s/^\w+//;
    $n2 =~ s/^\w+//;
    return $n1 <=> $n2;
  } else {
    return $n1 cmp $n2;
  }
}

sub chromosomes {
  my $self        = shift;
  my $db          = $self->db;
  my $chrom_type  = $self->chrom_type;
  my @chroms      = $db->features($chrom_type);
  
  # if no chromosomes defined, then generate from seqids
  unless (@chroms) {
      my @seq_ids = keys %{$self->{hits}};
      @chroms     = map {
	  Bio::Graphics::Feature->new(
	      -name   => $_->display_name,
	      -seq_id => $_->seq_id,
	      -start  => 1,
	      -end    => $_->length,
	      -type   => 'chromosome')
      } map {$db->segment(-name=>$_)} @seq_ids;
  }
  return @chroms;
}

sub generate_panels {
  my $self   = shift;
  my $format = shift || 'GD';

  my $image_class = $format;
  $image_class   .= '::Image' unless $image_class =~ /::Image/;
  eval "require $image_class" unless $image_class->can('new');

  my $chrom_type  = $self->chrom_type;
  my $chrom_width = $self->chrom_width;

  my @features    = grep {$self->hits($_->seq_id)} $self->chromosomes;
  return unless @features;

  my $minimal_width  = 0;
  my $maximal_length = 0;

  for my $f (@features) {
      my $name  = $f->seq_id;
      my $width = length($name) * gdSmallFont->width;
      $minimal_width  = $width if $chrom_width < $width;
      $maximal_length = $f->length if $maximal_length < $f->length;
  }
  $chrom_width = $minimal_width 
      if $chrom_width eq 'auto';
  my $pixels_per_base = $self->chrom_height / $maximal_length;
  my $band_colors     = $self->chrom_background;
  my $fallback_color  = $self->chrom_background_fallback;

  # each becomes a panel
  my %results;
  for my $chrom (@features) {
    my $height = int($chrom->length * $pixels_per_base);
    $height    = 20 if $height < 20;  # prevent tiny tiny chromosomes
    my $panel  = Bio::Graphics::Panel->new(-width => $height,  # not an error, will rotate image later
					   -length=> $chrom->length,
					   -pad_top   =>10,
					   -pad_bottom=>10,
					   -pad_right => 0,
					   -bgcolor   => $self->data_source->global_setting('overview bgcolor')
					    || 'wheat:0.5',
					   -image_class => $format,
	);

    my @hits  = $self->hits($chrom->seq_id);
    $panel->add_track(\@hits,
		      -glyph   => sub {
			  my $feature = shift;
			  return $feature->length/$chrom->length > 0.05
			      ? 'generic'
			      : 'diamond';
		      },
		      -maxdepth => 0,
		      -height  => 6,
		      -bgcolor => 'red',
		      -fgcolor => 'red',
		      -bump    => -1,
	);

    my $rotate = $panel->can('rotate') && $image_class->can('copyRotate90');

    my $method = $rotate ? 'add_track' : 'unshift_track';

    $panel->$method($chrom,
		    -glyph      => 'ideogram',                   # not an error, will rotate image later
		    -height     => $chrom_width,
		    -bgcolor    => $band_colors,
		    -bgfallback => $fallback_color,
		    -label    => 0,
		    -description => 0);

    $panel->rotate(1) if $rotate;      # need bioperl-live from 20 August 2008 for this to work
    $results{$chrom->seq_id}{chromosome} = $chrom;
    $results{$chrom->seq_id}{panel}      = $panel;
  }

  return \%results;
}

sub feature2id {
    my $self              = shift;
    my $feature           = shift;
    return overload::StrVal($feature);
}

sub hits_table {
    my $self                  = shift;
    my $term2hilite           = shift;

    local $^W = 0; # quash uninit variable warnings

    my @hits = $self->hits;

    my $regexp = join '|',($term2hilite =~ /(\w+)/g) 
	if defined $term2hilite;

    my $na   = $self->trans('NOT_APPLICABLE') || '-';

    my $sort_order = $self->seqid_order;
    my $url  = url(-absolute=>1,-path_info=>1)."?name=";

    # a way long map call here
    my @rows      = map {
	my $name  = $_->display_name || '';
	my $link  = $self->feature2link($_);
	my $id    = $self->feature2id($_);             # as an internal <div> id for hilighting
	my $pos   = $_->seq_id.':'.$_->start.'..'.$_->end;
	my $desc  = escapeHTML(Bio::Graphics::Glyph::generic->get_description($_));
	$desc =~ s/($regexp)/<b class="keyword">$1<\/b>/ig if $regexp;
	$desc =~ s/(\S{60})/$1 /g;  # wrap way long lines
	    
	TR({-class=>'nohilite',
	    -id=>"feature_${id}",
	    -onMouseOver=>"k_hilite_feature(this)",
	    -onMouseOut =>"k_unhilite_feature(this)",
	   },
	   th({-align=>'left'},a({-href=>$link},$name)),
	   td(eval{$_->method} || 'region'),
	   td($desc),
	   td(a({-href=>"$url$pos"},$pos)),
	   td($_->score || $na)
	    )
    } sort {
	($b->score||0)    <=>  ($a->score||0)
	    || $sort_order->{$a->seq_id} <=> $sort_order->{$b->seq_id}
	|| $a->start <=> $b->start
	    || $a->end   <=> $b->end
    } @hits;

    my $count = $self->language ? b($self->trans('HIT_COUNT',scalar @hits)) : '';

    return 
	b($count),
	div({-id=>'scrolling_table',-style=>'cursor:default'},
	    table({-class=>'searchbody',-style=>'width:95%'}, #firefox display problems
		  TR(
		      th({-align=>'left'},
			 [$self->trans('NAME'),
			  $self->trans('Type'),
			  $self->trans('Description'),
			  $self->trans('Position'),
			  $self->trans('score')
			 ])
		  ),
		  @rows)
	);
}


1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)