Raw content of Bio::Graphics::Glyph::dna package Bio::Graphics::Glyph::dna; use strict; use Bio::Graphics::Glyph::generic; use vars '@ISA'; @ISA = qw(Bio::Graphics::Glyph::generic); my %complement = (g=>'c',a=>'t',t=>'a',c=>'g',n=>'n', G=>'C',A=>'T',T=>'A',C=>'G',N=>'N'); # turn off description sub description { 0 } # turn off label # sub label { 1 } sub height { my $self = shift; my $font = $self->font; return $self->dna_fits ? 2*$font->height : $self->do_gc ? $self->SUPER::height : 0; } sub do_gc { my $self = shift; my $do_gc = $self->option('do_gc'); return if defined($do_gc) && !$do_gc; return 1; } sub draw_component { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2) = $self->bounds(@_); my $dna = eval { $self->feature->seq }; $dna = $dna->seq if ref($dna) and $dna->can('seq'); # to catch Bio::PrimarySeqI objects $dna or return; # workaround for my misreading of interface -- LS $dna = $dna->seq if ref($dna) && $dna->can('seq'); if ($self->dna_fits) { $self->draw_dna($gd,$dna,$x1,$y1,$x2,$y2); } elsif ($self->do_gc) { $self->draw_gc_content($gd,$dna,$x1,$y1,$x2,$y2); } } sub draw_dna { my $self = shift; my ($gd,$dna,$x1,$y1,$x2,$y2) = @_; my $pixels_per_base = $self->scale; my $feature = $self->feature; my $strand = $feature->strand; $strand *= -1 if $self->{flip}; my @bases = split '',$strand >= 0 ? $dna : $self->reversec($dna); my $color = $self->fgcolor; my $font = $self->font; my $lineheight = $font->height; $y1 -= $lineheight/2 - 3; my $strands = $self->option('strand') || 'auto'; my ($forward,$reverse); if ($strands eq 'auto') { $forward = $feature->strand >= 0; $reverse = $feature->strand <= 0; } elsif ($strands eq 'both') { $forward = $reverse = 1; } elsif ($strands eq 'reverse') { $reverse = 1; } else { $forward = 1; } my $start = $self->map_no_trunc($feature->start); my $end = $self->map_no_trunc($feature->end); my $offset = int(($x1-$start-1)/$pixels_per_base); for (my $i=$offset;$i<@bases;$i++) { my $x = $start + $i * $pixels_per_base; next if $x+1 < $x1; last if $x > $x2; $gd->char($font,$x+1,$y1,$bases[$i],$color) if $forward; $gd->char($font,$x+1,$y1+($forward ? $lineheight:0),$complement{$bases[$i]}||$bases[$i],$color) if $reverse; } } sub draw_gc_content { my $self = shift; my $gd = shift; my $dna = shift; my ($x1,$y1,$x2,$y2) = @_; my $bin_size = length($dna) / ($self->option('gc_bins') || 100); $bin_size = 100 if $bin_size < 100; my @bins; for (my $i = 0; $i < length($dna) - $bin_size; $i+= $bin_size) { my $subseq = substr($dna,$i,$bin_size); my $gc = $subseq =~ tr/gcGC/gcGC/; my $content = $gc/$bin_size; push @bins,$content; } push @bins,0.5 unless @bins; # avoid div by zero my $bin_width = ($x2-$x1)/@bins; my $bin_height = $y2-$y1; my $fgcolor = $self->fgcolor; my $bgcolor = $self->factory->translate_color($self->panel->gridcolor); my $axiscolor = $self->color('axis_color') || $fgcolor; $gd->line($x1, $y1, $x1, $y2, $axiscolor); $gd->line($x2-2,$y1, $x2-2,$y2, $axiscolor); $gd->line($x1, $y1, $x1+3,$y1, $axiscolor); $gd->line($x1, $y2, $x1+3,$y2, $axiscolor); $gd->line($x1, ($y2+$y1)/2,$x1+3,($y2+$y1)/2,$axiscolor); $gd->line($x2-4,$y1, $x2-1, $y1, $axiscolor); $gd->line($x2-4,$y2, $x2-1, $y2, $axiscolor); $gd->line($x2-4,($y2+$y1)/2,$x2-1,($y2+$y1)/2,$axiscolor); $gd->line($x1+5,$y2, $x2-5,$y2, $bgcolor); $gd->line($x1+5,($y2+$y1)/2,$x2-5,($y2+$y1)/2,$bgcolor); $gd->line($x1+5,$y1, $x2-5,$y1, $bgcolor); $gd->string($self->font,$x1+5,$y1,'% gc',$axiscolor) if $bin_height > $self->font->height*2; for (my $i = 0; $i < @bins; $i++) { my $bin_start = $x1+$i*$bin_width; my $bin_stop = $bin_start + $bin_width; my $y = $y2 - ($bin_height*$bins[$i]); $gd->line($bin_start,$y,$bin_stop,$y,$fgcolor); $gd->line($bin_stop,$y,$bin_stop,$y2 - ($bin_height*$bins[$i+1]),$fgcolor) if $i < @bins-1; } } sub make_key_feature { my $self = shift; my @gatc = qw(g a t c); my $offset = $self->panel->offset; my $scale = 1/$self->scale; # base pairs/pixel my $start = $offset+1; my $stop = $offset+100*$scale; my $feature = Bio::Graphics::Feature->new(-start=> $start, -stop => $stop, -seq => join('',map{$gatc[rand 4]} (1..500)), -name => $self->option('key'), -strand => '+1', ); $feature; } 1; __END__ =head1 NAME Bio::Graphics::Glyph::dna - The "dna" glyph =head1 SYNOPSIS See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>. =head1 DESCRIPTION This glyph draws DNA sequences. At high magnifications, this glyph will draw the actual base pairs of the sequence (both strands). At low magnifications, the glyph will plot the GC content. For this glyph to work, the feature must return a DNA sequence string in response to the dna() method. =head2 OPTIONS The following options are standard among all Glyphs. See L<Bio::Graphics::Glyph> for a full explanation. Option Description Default ------ ----------- ------- -fgcolor Foreground color black -outlinecolor Synonym for -fgcolor -bgcolor Background color turquoise -fillcolor Synonym for -bgcolor -linewidth Line width 1 -height Height of glyph 10 -font Glyph font gdSmallFont -connector Connector type 0 (false) -connector_color Connector color black -label Whether to draw a label 0 (false) -description Whether to draw a description 0 (false) In addition to the common options, the following glyph-specific options are recognized: Option Description Default ------ ----------- ------- -do_gc Whether to draw the GC true graph at low mags -gc_bins Fixed number of intervals 100 to sample across the panel. -axis_color Color of the vertical axes fgcolor in the GC content graph -strand Show both forward and auto reverse strand, one of "forward", "reverse", "both" or "auto". In "auto" mode, +1 strand features will show the plus strand -1 strand features will show the reverse complement and strandless features will show both =head1 BUGS Please report them. =head1 SEE ALSO L<Bio::Graphics::Panel>, L<Bio::Graphics::Glyph>, L<Bio::Graphics::Glyph::arrow>, L<Bio::Graphics::Glyph::cds>, L<Bio::Graphics::Glyph::crossbox>, L<Bio::Graphics::Glyph::diamond>, L<Bio::Graphics::Glyph::dna>, L<Bio::Graphics::Glyph::dot>, L<Bio::Graphics::Glyph::ellipse>, L<Bio::Graphics::Glyph::extending_arrow>, L<Bio::Graphics::Glyph::generic>, L<Bio::Graphics::Glyph::graded_segments>, L<Bio::Graphics::Glyph::heterogeneous_segments>, L<Bio::Graphics::Glyph::line>, L<Bio::Graphics::Glyph::pinsertion>, L<Bio::Graphics::Glyph::primers>, L<Bio::Graphics::Glyph::rndrect>, L<Bio::Graphics::Glyph::segments>, L<Bio::Graphics::Glyph::ruler_arrow>, L<Bio::Graphics::Glyph::toomany>, L<Bio::Graphics::Glyph::transcript>, L<Bio::Graphics::Glyph::transcript2>, L<Bio::Graphics::Glyph::translation>, L<Bio::Graphics::Glyph::triangle>, L<Bio::DB::GFF>, L<Bio::SeqI>, L<Bio::SeqFeatureI>, L<Bio::Das>, L<GD> =head1 AUTHOR Lincoln Stein E<lt>lstein@cshl.orgE<gt>. Copyright (c) 2001 Cold Spring Harbor Laboratory This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See DISCLAIMER.txt for disclaimers of warranty. =cut