Skip to content
Browse files

This commit was manufactured by cvs2svn to create tag 'release-1_01'.

  • Loading branch information...
1 parent 4cdb02d commit d95985193fc0791ef6c92f5ccd43a750cec81a79 Nobody committed Mar 23, 2002
View
319 Graphics/Feature.pm
@@ -1,319 +0,0 @@
-package Bio::Graphics::Feature;
-use strict;
-
-use vars '$VERSION';
-$VERSION = 1.2;
-
-*stop = \&end;
-*info = \&name;
-*seqname = \&name;
-*type = \&primary_tag;
-*exons = *sub_SeqFeature = *merged_segments = \&segments;
-*class = *method = \&type;
-*source = \&source_tag;
-
-# usage:
-# Bio::Graphics::Feature->new(
-# -start => 1,
-# -end => 100,
-# -name => 'fred feature',
-# -strand => +1);
-#
-# Alternatively, use -segments => [ [start,stop],[start,stop]...]
-# to create a multisegmented feature.
-sub new {
- my $class= shift;
- $class = ref($class) if ref $class;
- my %arg = @_;
-
- my $self = bless {},$class;
-
- $arg{-strand} ||= 0;
- $self->{strand} = $arg{-strand} >= 0 ? +1 : -1;
- $self->{name} = $arg{-name};
- $self->{type} = $arg{-type} || 'feature';
- $self->{subtype} = $arg{-subtype} if exists $arg{-subtype};
- $self->{source} = $arg{-source} || $arg{-source_tag} || '';
- $self->{score} = $arg{-score} || 0;
- $self->{start} = $arg{-start};
- $self->{stop} = $arg{-end} || $arg{-stop};
- $self->{ref} = $arg{-ref};
- $self->{url} = $arg{-url} if $arg{-url};
-
- # fix start, stop
- if (defined $self->{stop} && defined $self->{start}
- && $self->{stop} < $self->{start}) {
- @{$self}{'start','stop'} = @{$self}{'stop','start'};
- $self->{strand} *= -1;
- }
-
- my @segments;
- if (my $s = $arg{-segments}) {
- $self->add_segment(@$s);
- }
- $self;
-}
-
-sub add_segment {
- my $self = shift;
- my $type = $self->{subtype} || $self->{type};
- $self->{segments} ||= [];
-
- my @segments = @{$self->{segments}};
-
- for my $seg (@_) {
- if (ref($seg) eq 'ARRAY') {
- my ($start,$stop) = @{$seg};
- next unless defined $start && defined $stop; # fixes an obscure bug somewhere above us
- my $strand = $self->{strand};
-
- if ($start > $stop) {
- ($start,$stop) = ($stop,$start);
- $strand *= -1;
- }
- push @segments,$self->new(-start=>$start,
- -stop=>$stop,
- -strand=>$strand,
- -type => $type);
- } else {
- push @segments,$seg;
- }
- }
- if (@segments) {
- $self->{segments} = [ sort {$a->start <=> $b->start } @segments ];
- $self->{start} = $self->{segments}[0]->start;
- ($self->{stop}) = sort { $b <=> $a } map { $_->end } @segments;
- }
-}
-
-sub location {
- my $self = shift;
-
- require Bio::Location::Split;
- my @segments = $self->segments;
- if (@segments) {
- my $split = Bio::Location::Split->new;
- foreach (@segments) {
- $split->add_sub_Location(Bio::Location::Simple->new(-start => $_->start,
- -end => $_->end,
- -strand => $_->strand
- ));
- }
- return $split;
- }
- return Bio::Location::Simple->new(-start => $self->start,
- -end => $self->end,
- -strand => $self->strand);
-}
-
-sub segments {
- my $self = shift;
- my $s = $self->{segments} or return wantarray ? () : 0;
- @$s;
-}
-sub score {
- my $self = shift;
- my $d = $self->{score};
- $self->{score} = shift if @_;
- $d;
-}
-sub primary_tag { shift->{type} }
-sub name { shift->{name} }
-sub ref {
- my $self = shift;
- my $d = $self->{ref};
- $self->{ref} = shift if @_;
- $d;
-}
-sub start {
- my $self = shift;
- my $d = $self->{start};
- $self->{start} = shift if @_;
- $d;
-}
-sub end {
- my $self = shift;
- my $d = $self->{stop};
- $self->{stop} = shift if @_;
- $d;
-}
-sub strand {
- my $self = shift;
- my $d = $self->{strand};
- $self->{strand} = shift if @_;
- $d;
-}
-sub length {
- my $self = shift;
- return $self->end - $self->start + 1;
-}
-
-sub seq {
- my $self = shift;
- return scalar('n' x $self->length);
-}
-*dna = \&seq;
-
-sub source_tag {
- my $self = shift;
- my $d = $self->{source};
- $self->{source} = shift if @_;
- $d;
-}
-
-# This probably should be deleted. Not sure why it's here, but might
-# have been added for Ace::Sequence::Feature-compliance.
-sub introns {
- my $self = shift;
- return;
-}
-
-# get/set the configurator (Bio::Graphics::FeatureFile) for this feature
-sub configurator {
- my $self = shift;
- my $d = $self->{configurator};
- $self->{configurator} = shift if @_;
- $d;
-}
-
-# get/set the url for this feature
-sub url {
- my $self = shift;
- my $d = $self->{url};
- $self->{url} = shift if @_;
- $d;
-}
-
-# make a link
-sub make_link {
- my $self = shift;
- if (my $url = $self->url) {
- return $url;
- }
-
- elsif (my $configurator = $self->configurator) {
- return $configurator->make_link($self);
- }
-
- else {
- return;
- }
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Bio::Graphics::Feature - A simple feature object for use with Bio::Graphics::Panel
-
-=head1 SYNOPSIS
-
- use Bio::Graphics::Feature;
-
- # create a simple feature with no internal structure
- $f = Bio::Graphics::Feature->new(-start => 1000,
- -stop => 2000,
- -type => 'transcript',
- -name => 'alpha-1 antitrypsin'
- );
-
- # create a feature composed of multiple segments, all of type "similarity"
- $f = Bio::Graphics::Feature->new(-segments => [[1000,1100],[1500,1550],[1800,2000]],
- -name => 'ABC-3',
- -type => 'gapped_alignment',
- -subtype => 'similarity');
-
- # build up a gene exon by exon
- $e1 = Bio::Graphics::Feature->new(-start=>1,-stop=>100,-type=>'exon');
- $e2 = Bio::Graphics::Feature->new(-start=>150,-stop=>200,-type=>'exon');
- $e3 = Bio::Graphics::Feature->new(-start=>300,-stop=>500,-type=>'exon');
- $f = Bio::Graphics::Feature->new(-segments=>[$e1,$e2,$e3],-type=>'gene');
-
-=head1 DESCRIPTION
-
-This is a simple Bio::SeqFeatureI-compliant object that is compatible
-with Bio::Graphics::Panel. With it you can create lightweight feature
-objects for drawing.
-
-All methods are as described in L<Bio::SeqFeatureI> with the following additions:
-
-=head2 The new() Constructor
-
- $feature = Bio::Graphics::Feature->new(@args);
-
-This method creates a new feature object. You can create a simple
-feature that contains no subfeatures, or a hierarchically nested object.
-
-Arguments are as follows:
-
- -start the start position of the feature
- -stop the stop position of the feature
- -end an alias for stop
- -name the feature name (returned by seqname())
- -type the feature type (returned by primary_tag())
- -source the source tag
- -segments a list of subfeatures (see below)
- -subtype the type to use when creating subfeatures
-
-The subfeatures passed in -segments may be an array of
-Bio::Graphics::Feature objects, or an array of [$start,$stop]
-pairs. Each pair should be a two-element array reference. In the
-latter case, the feature type passed in -subtype will be used when
-creating the subfeatures.
-
-If no feature type is passed, then it defaults to "feature".
-
-=head2 Non-SeqFeatureI methods
-
-A number of new methods are provided for compatibility with
-Ace::Sequence, which has a slightly different API from SeqFeatureI:
-
-=over 4
-
-=item add_segment(@segments)
-
-Add one or more segments (a subfeature). Segments can either be
-Feature objects, or [start,stop] arrays, as in the -segments argument
-to new(). The feature endpoints are automatically adjusted.
-
-=item segments()
-
-An alias for sub_SeqFeatures().
-
-=item merged_segments()
-
-Another alias for sub_SeqFeatures().
-
-=item stop()
-
-An alias for end().
-
-=item name()
-
-An alias for seqname().
-
-=item exons()
-
-An alias for sub_SeqFeatures() (you don't want to know why!)
-
-=back
-
-=head1 SEE ALSO
-
-L<Bio::Graphics::Panel>,L<Bio::Graphics::Glyph>,
-L<GD>
-
-=head1 AUTHOR
-
-Lincoln Stein <lstein@cshl.org>.
-
-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
View
642 Graphics/FeatureFile.pm
@@ -1,642 +0,0 @@
-package Bio::Graphics::FeatureFile;
-# $Id: FeatureFile.pm,v 1.18 2002-03-06 11:54:06 lstein Exp $
-
-# This package parses and renders a simple tab-delimited format for features.
-# It is simpler than GFF, but still has a lot of expressive power.
-
-# Documentation is pending, but see __END__ for the file format, and eg/feature_draw.pl for an
-# example of usage.
-
-use strict;
-use Bio::Graphics::Feature;
-use Carp;
-use IO::File;
-use Text::Shellwords;
-use vars '$VERSION';
-$VERSION = '1.01';
-
-# default colors for unconfigured features
-my @COLORS = qw(cyan blue red yellow green wheat turquoise orange);
-use constant WIDTH => 600;
-
-# args array:
-# -file => parse from a file (- allowed for ARGV)
-# -text => parse from a text scalar
-# -map_coords => code ref to do coordinate mapping
-# called with ($ref,[$start1,$stop1],[$start2,$stop2]...)
-# returns ($newref,$new_coord1,$new_coord2...)
-
-sub new {
- my $class = shift;
- my %args = @_;
- my $self = bless {
- config => {},
- features => {},
- groups => {},
- seenit => {},
- types => [],
- max => undef,
- min => undef,
- stat => [],
- refs => {},
- },$class;
- $self->{coordinate_mapper} = $args{-map_coords}
- if exists $args{-map_coords} && ref($args{-map_coords}) eq 'CODE';
- $self->{smart_features} = $args{-smart_features} if exists $args{-smart_features};
-
- # call with
- # -file
- # -text
- my $fh;
- if (my $file = $args{-file}) {
- no strict 'refs';
- if (defined fileno($file)) {
- $fh = $file;
- } elsif ($file eq '-') {
- $self->parse_argv();
- } else {
- $fh = IO::File->new($file) or croak("Can't open $file: $!\n");
- }
- $self->parse_file($fh);
- } elsif (my $text = $args{-text}) {
- $self->parse_text($text);
- }
- $fh->close or warn "Error closing file: $!" if $fh;
- $self;
-}
-
-sub error {
- my $self = shift;
- my $d = $self->{error};
- $self->{error} = shift if @_;
- $d;
-}
-
-sub smart_features {
- my $self = shift;
- my $d = $self->{smart_features};
- $self->{smart_features} = shift if @_;
- $d;
-}
-
-sub parse_argv {
- my $self = shift;
-
- $self->init_parse;
- while (<>) {
- chomp;
- $self->parse_line($_);
- }
- $self->finish_parse;
-}
-
-sub parse_file {
- my $self = shift;
- my $fh = shift or return;
- $self->_stat($fh);
-
- $self->{seenit} = {};
- while (<$fh>) {
- chomp;
- $self->parse_line($_);
- }
- $self->consolidate_groups;
-}
-
-sub parse_text {
- my $self = shift;
- my $text = shift;
-
- $self->{seenit} = {};
- $self->{features} = {};
- foreach (split /\r?\n|\r\n?/,$text) {
- $self->parse_line($_);
- }
- $self->consolidate_groups;
- delete $self->{seenit};
-}
-
-sub parse_line {
- my $self = shift;
- local $_ = shift;
-
- s/\r//g; # get rid of carriage returns left over by MS-DOS/Windows systems
-
- return if /^[\#]/;
-
- if (/^\s+(.+)/ && $self->{current_tag}) { # continuation line
- my $value = $1;
- my $cc = $self->{current_config} ||= 'general'; # in case no configuration named
- $self->{config}{$cc}{$self->{current_tag}} .= ' ' . $value;
- return;
- }
-
- if (/^\s*\[([^\]]+)\]/) { # beginning of a configuration section
- my $label = $1;
- my $cc = $label =~ /^(general|default)$/i ? 'general' : $label; # normalize
- push @{$self->{types}},$cc unless $cc eq 'general';
- $self->{current_config} = $cc;
- return;
- }
-
- if (/^([\w ]+?)\s*=\s*(.*)/) { # key value pair within a configuration section
- my $tag = lc $1;
- my $cc = $self->{current_config} ||= 'general'; # in case no configuration named
- my $value = defined $2 ? $2 : '';
- $self->{config}{$cc}{$tag} = $value;
- $self->{current_tag} = $tag;
- return;
- }
-
-
- if (/^$/) { # empty line
- undef $self->{current_tag};
- return;
- }
-
- # parse data lines
- my @tokens = eval { shellwords($_||'') };
- unshift @tokens,'' if /^\s+/;
-
- # close any open group
- undef $self->{grouptype} if length $tokens[0] > 0;
-
- if (@tokens < 3) { # short line; assume a group identifier
- $self->{grouptype} = shift @tokens;
- $self->{groupname} = shift @tokens;
- return;
- }
-
- my($ref,$type,$name,$strand,$bounds,$description,$url);
-
- if (@tokens >= 8) { # conventional GFF file
- my ($r,$source,$method,$start,$stop,$score,$s,$phase,@rest) = @tokens;
- my $group = join ' ',@rest;
- $type = join(':',$method,$source);
- $bounds = join '..',$start,$stop;
- $strand = $s;
- if ($group) {
- my ($notes,@notes);
- (undef,$self->{groupname},undef,undef,$notes) = split_group($group);
- foreach (@$notes) {
- if (m!^(http|ftp)://!) { $url = $_ } else { push @notes,$_ }
- }
- $description = join '; ',@notes if @notes;
- }
- $name ||= $self->{groupname};
- $ref = $r;
- }
-
- elsif ($tokens[2] =~ /^([+-.]|[+-]?[01])$/) { # old simplified version
- ($type,$name,$strand,$bounds,$description,$url) = @tokens;
- } else { # new simplified version
- ($type,$name,$bounds,$description,$url) = @tokens;
- }
-
- $type ||= $self->{grouptype};
- $type =~ s/\s+$//; # get rid of excess whitespace
-
- # the reference is specified by the GFF reference line first,
- # the last reference line we saw second,
- # or the reference line in the "general" section.
- {
- local $^W = 0;
- $ref ||= $self->{config}{$self->{current_config}}{'reference'}
- || $self->{config}{general}{reference};
- }
- $self->{refs}{$ref}++ if defined $ref;
-
- my @parts = map { [/(-?\d+)(?:-|\.\.)(-?\d+)/]} split /(?:,| )\s*/,$bounds;
-
- foreach (@parts) { # max and min calculation, sigh...
- $self->{min} = $_->[0] if !defined $self->{min} || $_->[0] < $self->{min};
- $self->{max} = $_->[1] if !defined $self->{max} || $_->[1] > $self->{max};
- }
-
- if ($self->{coordinate_mapper} && $ref) {
- ($ref,@parts) = $self->{coordinate_mapper}->($ref,@parts);
- return unless $ref;
- }
-
- # either create a new feature or add a segment to it
- if (my $feature = $self->{seenit}{$type,$name}) {
- $feature->add_segment(@parts);
- } else {
- $feature = $self->{seenit}{$type,$name} = Bio::Graphics::Feature->new(-name => $name,
- -type => $type,
- $strand ? (-strand => make_strand($strand))
- : (),
- -segments => \@parts,
- -source => $description,
- -ref => $ref,
- -url => $url,
- );
- $feature->configurator($self) if $self->smart_features;
- if ($self->{grouptype}) {
- push @{$self->{groups}{$self->{grouptype}}{$self->{groupname}}},$feature;
- } else {
- push @{$self->{features}{$type}},$feature;
- }
- }
-}
-
-# break circular references
-sub destroy {
- my $self = shift;
- delete $self->{features};
-}
-
-# return configuration information
-sub setting {
- my $self = shift;
- my $config = $self->{config} or return;
- return keys %{$config} unless @_;
- return keys %{$config->{$_[0]}} if @_ == 1;
- return $config->{$_[0]}{$_[1]} if @_ > 1;
-}
-
-sub code_setting {
- my $self = shift;
- my $section = shift;
- my $option = shift;
-
- my $setting = $self->setting($section=>$option);
- return unless defined $setting;
- return $setting if ref($setting) eq 'CODE';
- return $setting unless $setting =~ /^sub\s+\{/;
- my $coderef = eval $setting;
- warn $@ if $@;
-
- return $self->{$section}{$option} = $coderef;
-}
-
-# turn configuration into a set of -name=>value pairs suitable for add_track()
-sub style {
- my $self = shift;
- my $type = shift;
-
- my $config = $self->{config} or return;
- my $hashref = $config->{$type} or return;
-
- return map {("-$_" => $hashref->{$_})} keys %$hashref;
-}
-
-# retrieve just the glyph part of the configuration
-sub glyph {
- my $self = shift;
- my $type = shift;
- my $config = $self->{config} or return;
- my $hashref = $config->{$type} or return;
- return $hashref->{glyph};
-}
-
-# return list of configured types, in proper order
-sub configured_types {
- my $self = shift;
- my $types = $self->{types} or return;
- return @{$types};
-}
-
-# return features
-sub features {
- my $self = shift;
- return $self->{features}{shift()} if @_;
- return $self->{features};
-}
-
-sub types {
- my $self = shift;
- my $features = $self->{features} or return;
- return keys %{$features};
-}
-
-
-sub make_strand {
- local $^W = 0;
- return +1 if $_[0] =~ /^\+/ || $_[0] > 0;
- return -1 if $_[0] =~ /^\-/ || $_[0] < 0;
- return 0;
-}
-
-sub min { shift->{min} }
-sub max { shift->{max} }
-
-sub init_parse {
- my $s = shift;
-
- $s->{seenit} = {};
- $s->{max} = $s->{min} = undef;
- $s->{types} = [];
- $s->{groups} = {};
- $s->{features} = {};
- $s->{config} = {}
-}
-
-sub finish_parse {
- my $s = shift;
- $s->consolidate_groups;
- $s->{seenit} = {};
- $s->{groups} = {};
-}
-
-sub consolidate_groups {
- my $self = shift;
- my $groups = $self->{groups} or return;
-
- for my $type (keys %$groups) {
- my @groups = values %{$groups->{$type}};
- push @{$self->{features}{$type}},@groups;
- }
-}
-
-sub split_group {
- my $group = shift;
-
- $group =~ s/\\;/$;/g; # protect embedded semicolons in the group
- $group =~ s/( \"[^\"]*);([^\"]*\")/$1$;$2/g;
- my @groups = split(/\s*;\s*/,$group);
- foreach (@groups) { s/$;/;/g }
-
- my ($gclass,$gname,$tstart,$tstop,@notes);
-
- foreach (@groups) {
-
- my ($tag,$value) = /^(\S+)\s*(.*)/;
- $value =~ s/\\t/\t/g;
- $value =~ s/\\r/\r/g;
- $value =~ s/^"//;
- $value =~ s/"$//;
-
- # if the tag is "Note", then we add this to the
- # notes array
- if ($tag eq 'Note') { # just a note, not a group!
- push @notes,$value;
- }
-
- # if the tag eq 'Target' then the class name is embedded in the ID
- # (the GFF format is obviously screwed up here)
- elsif ($tag eq 'Target' && $value =~ /([^:\"]+):([^\"]+)/) {
- ($gclass,$gname) = ($1,$2);
- ($tstart,$tstop) = /(\d+) (\d+)/;
- }
-
- elsif (!$value) {
- push @notes,$tag; # e.g. "Confirmed_by_EST"
- }
-
- # otherwise, the tag and value correspond to the
- # group class and name
- else {
- ($gclass,$gname) = ($tag,$value);
- }
- }
-
- return ($gclass,$gname,$tstart,$tstop,\@notes);
-}
-
-# render our features onto a panel using configuration data
-# return the number of tracks inserted
-sub render {
- my $self = shift;
- my $panel = shift;
- my ($position_to_insert,$options) = @_;
-
- $panel ||= $self->new_panel;
-
- # count up number of tracks inserted
- my $tracks = 0;
- my $color;
- my %types = map {$_=>1} $self->configured_types;
-
- my @configured_types = grep {exists $self->features->{$_}} $self->configured_types;
- my @unconfigured_types = sort grep {!exists $types{$_}} $self->types;
-
- my @base_config = $self->style('general');
-
- $options ||= 0;
- my @override = ();
- push @override,(-bump => 1) if $options >= 1;
- push @override,(-label =>1) if $options >= 2;
-
- for my $type (@configured_types,@unconfigured_types) {
- my @config = ( -glyph => 'segments', # really generic
- -bgcolor => $COLORS[$color++ % @COLORS],
- -label => 1,
- -key => $type,
- @base_config, # global
- $self->style($type), # feature-specificp
- @override,
- );
- my $features = $self->features($type);
- if (defined($position_to_insert)) {
- $panel->insert_track($position_to_insert++,$features,@config);
- } else {
- $panel->add_track($features,@config);
- }
- $tracks++;
- }
- $tracks;
-}
-
-# create a panel if needed
-sub new_panel {
- my $self = shift;
-
- # general configuration of the image here
- my $width = $self->setting(general => 'pixels')
- || $self->setting(general => 'width')
- || WIDTH;
-
- my ($start,$stop);
- my $range_expr = '(-?\d+)(?:-|\.\.)(-?\d+)';
-
- if (my $bases = $self->setting(general => 'bases')) {
- ($start,$stop) = $bases =~ /([\d-]+)(?:-|\.\.)([\d-]+)/;
- }
-
- if (!defined $start || !defined $stop) {
- $start = $self->min unless defined $start;
- $stop = $self->max unless defined $stop;
- }
-
- my $new_segment = Bio::Graphics::Feature->new(-start=>$start,-stop=>$stop);
- my $panel = Bio::Graphics::Panel->new(-segment => $new_segment,
- -width => $width,
- -key_style => 'between');
- $panel;
-}
-
-sub _stat {
- my $self = shift;
- my $fh = shift;
- $self->{stat} = [stat($fh)];
-}
-
-sub mtime { shift->{stat}->[9]; }
-sub atime { shift->{stat}->[8]; }
-sub ctime { shift->{stat}->[10]; }
-sub size { shift->{stat}->[7]; }
-sub refs {
- my $self = shift;
- my $refs = $self->{refs} or return;
- keys %$refs;
-}
-
-sub feature2label {
- my $self = shift;
- my $feature = shift;
- my $type = eval {$feature->type} or return;
- my $label = $self->type2label($type) || $self->type2label($feature->primary_tag) || $type;
- $label;
-}
-
-sub make_link {
- my $self = shift;
- my $feature = shift;
- my $label = $self->feature2label($feature) or return;
- my $link = $self->setting($label,'link');
- $link = $self->setting(general=>'link') unless defined $link;
- return unless $link;
- return $self->link_pattern($link,$feature);
-}
-
-sub link_pattern {
- my $self = shift;
- my ($pattern,$feature) = @_;
- $pattern =~ s/\$(\w+)/
- $1 eq 'name' ? $feature->name
- : $1 eq 'class' ? $feature->class
- : $1 eq 'type' ? $feature->method
- : $1 eq 'method' ? $feature->method
- : $1 eq 'source' ? $feature->source
- : $1
- /exg;
- return $pattern;
-}
-
-# given a feature type, return its label
-sub type2label {
- my $self = shift;
- my $type = shift;
- $self->{_type2label} ||= $self->invert_types;
- $self->{_type2label}{$type};
-}
-
-sub invert_types {
- my $self = shift;
- my $config = $self->{config} or return;
- my %inverted;
- for my $label (keys %{$config}) {
- my $feature = $config->{$label}{feature} or next;
- foreach (shellwords($feature||'')) {
- $inverted{$_} = $label;
- }
- }
- \%inverted;
-}
-
-# This routine returns the "citation" field. It is here in order to simplify the logic
-# a bit in the generic browser
-sub citation {
- my $self = shift;
- my $feature = shift || 'general';
- return $self->setting($feature=>'citation');
-}
-
-# give this feature file a nickname
-sub name {
- my $self = shift;
- my $d = $self->{name};
- $self->{name} = shift if @_;
- $d;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Bio::Graphics::FeatureFile - Parse a simple feature file format into a form suitable for rendering
-
-=head1 SYNOPSIS
-
-This package parses and renders a simple tab-delimited format for features.
-It is simpler than GFF, but still has a lot of expressive power.
-
-Documentation is pending, but see the file format here, and eg/feature_draw.pl for an
-example of usage.
-
- # file begins
- [general]
- pixels = 1024
- bases = 1-20000
- height = 12
-
- [Cosmid]
- glyph = segments
- fgcolor = blue
- key = C. elegans conserved regions
-
- [EST]
- glyph = segments
- bgcolor= yellow
- connector = dashed
- height = 5;
-
- [FGENESH]
- glyph = transcript2
- bgcolor = green
- description = 1
-
- Cosmid B0511 + 516-619
- Cosmid B0511 + 3185-3294
- Cosmid B0511 + 10946-11208
- Cosmid B0511 + 13126-13511
- Cosmid B0511 + 11394-11539
- Cosmid B0511 + 14383-14490
- Cosmid B0511 + 15569-15755
- Cosmid B0511 + 18879-19178
- Cosmid B0511 + 15850-16110
- Cosmid B0511 + 66-208
- Cosmid B0511 + 6354-6499
- Cosmid B0511 + 13955-14115
- Cosmid B0511 + 7985-8042
- Cosmid B0511 + 11916-12046
- EST yk260e10.5 + 15569-15724
- EST yk672a12.5 + 537-618,3187-3294
- EST yk595e6.5 + 552-618
- EST yk595e6.5 + 3187-3294
- EST yk846e07.3 + 11015-11208
- EST yk53c10
- yk53c10.3 + 15000-15500,15700-15800
- yk53c10.5 + 18892-19154
- EST yk53c10.5 + 16032-16105
- SwissProt PECANEX + 13153-13656 Swedish fish
- FGENESH Predicted gene 1 - 1-205,518-616,661-735,3187-3365,3436-3846 Pfam domain
- FGENESH Predicted gene 2 + 5513-6497,7968-8136,8278-8383,8651-8839,9462-9515,10032-10705,10949-11340,11387-11524,11765-12067,12876-13577,13882-14121,14169-14535,15006-15209,15259-15462,15513-15753,15853-16219 Mysterious
- FGENESH Predicted gene 3 - 16626-17396,17451-17597
- FGENESH Predicted gene 4 + 18459-18722,18882-19176,19221-19513,19572-19835 Transmembrane protein
- # file ends
-
-=head1 SEE ALSO
-
-L<Bio::Graphics::Panel>,
-L<Bio::Graphics::Glyph>,
-L<Bio::Graphics::Feature>,
-L<Bio::Graphics::FeatureFile>
-
-=head1 AUTHOR
-
-Lincoln Stein <lstein@cshl.org>.
-
-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
-
-
-
View
1,198 Graphics/Glyph.pm
@@ -1,1198 +0,0 @@
-package Bio::Graphics::Glyph;
-use GD;
-
-use strict;
-use Carp 'croak';
-use constant BUMP_SPACING => 2; # vertical distance between bumped glyphs
-
-my %LAYOUT_COUNT;
-
-# a bumpable graphical object that has bumpable graphical subparts
-
-# args: -feature => $feature_object (may contain subsequences)
-# -factory => $factory_object (called to create glyphs for subsequences)
-# In this scheme, the factory decides based on stylesheet information what glyph to
-# draw and what configurations options to us. This allows for heterogeneous tracks.
-sub new {
- my $class = shift;
- my %arg = @_;
-
- my $feature = $arg{-feature} or die "No feature";
- my $factory = $arg{-factory} || $class->default_factory;
-
- my $self = bless {},$class;
- $self->{feature} = $feature;
- $self->{factory} = $factory;
- $self->{top} = 0;
-
- my @subglyphs;
- my @subfeatures = $self->subseq($feature);
-
- if (@subfeatures) {
-
- # dynamic glyph resolution
- @subglyphs = sort { $a->left <=> $b->left } $factory->make_glyph(@subfeatures);
-
- $self->{parts} = \@subglyphs;
- }
-
- if (defined $self->start && defined $self->stop) {
- my ($left,$right) = $factory->map_pt($self->start,$self->stop);
- ($left,$right) = ($right,$left) if $left > $right; # paranoia
- $self->{left} = $left;
- $self->{width} = $right - $left + 1;
- }
- if (@subglyphs) {
- my $l = $subglyphs[0]->left;
- $self->{left} = $l if !defined($self->{left}) || $l < $self->{left};
- my $right = (sort { $b<=>$a } map {$_->right} @subglyphs)[0];
- my $w = $right - $self->{left} + 1;
- $self->{width} = $w if !defined($self->{width}) || $w > $self->{width};
- }
-
- #Handle glyphs that don't actually fill their space, but merely mark a point.
- #They need to have their collision bounds altered. We will (for now)
- #hard code them to be in the center of their feature.
- $self->{point} = $arg{-point} ? $self->height : undef;
- if($self->option('point')){
- my ($left,$right) = $factory->map_pt($self->start,$self->stop);
- my $center = int(($left+$right)/2);
-
- $self->{width} = $self->height;
- $self->{left} = $center - ($self->{width});
- $self->{right} = $center + ($self->{width});
- }
-
- return $self;
-}
-
-sub parts {
- my $self = shift;
- return unless $self->{parts};
- return wantarray ? @{$self->{parts}} : $self->{parts};
-}
-
-sub feature { shift->{feature} }
-sub factory { shift->{factory} }
-sub panel { shift->factory->panel }
-sub point { shift->{point} }
-sub scale { shift->factory->scale }
-sub start {
- my $self = shift;
- return $self->{start} if exists $self->{start};
- $self->{start} = $self->{feature}->start;
-
- # handle the case of features whose endpoints are undef
- # (this happens with wormbase clones where one or more clone end is not defined)
- # in this case, we set the start to one minus the beginning of the panel
- $self->{start} = $self->panel->offset - 1 unless defined $self->{start};
-
- return $self->{start};
-}
-sub stop {
- my $self = shift;
- return $self->{stop} if exists $self->{stop};
- $self->{stop} = $self->{feature}->end;
-
- # handle the case of features whose endpoints are undef
- # (this happens with wormbase clones where one or more clone end is not defined)
- # in this case, we set the start to one plus the end of the panel
- $self->{stop} = $self->panel->offset + $self->panel->length + 1 unless defined $self->{stop};
-
- return $self->{stop}
-}
-sub end { shift->stop }
-sub map_pt { shift->{factory}->map_pt(@_) }
-
-# add a feature (or array ref of features) to the list
-sub add_feature {
- my $self = shift;
- my $factory = $self->factory;
- for my $feature (@_) {
- if (ref $feature eq 'ARRAY') {
- $self->add_group(@$feature);
- } else {
- push @{$self->{parts}},$factory->make_glyph($feature);
- }
- }
-}
-
-# link a set of features together so that they bump as a group
-sub add_group {
- my $self = shift;
- my @features = ref($_[0]) eq 'ARRAY' ? @{$_[0]} : @_;
- my $f = Bio::Graphics::Feature->new(
- -segments=>\@features,
- -type => 'group'
- );
- $self->add_feature($f);
-}
-
-sub top {
- my $self = shift;
- my $g = $self->{top};
- $self->{top} = shift if @_;
- $g;
-}
-sub left {
- my $self = shift;
-# return $self->{cache_left} if exists $self->{cache_left};
-# $self->{cache_left} = $self->{left} - $self->pad_left;
- return $self->{left} - $self->pad_left;
-}
-sub right {
- my $self = shift;
-# return $self->{cache_right} if exists $self->{cache_right};
-# $self->{cache_right} = $self->left + $self->layout_width - 1;
- return $self->left + $self->layout_width - 1;
-}
-sub bottom {
- my $self = shift;
- $self->top + $self->layout_height - 1;
-}
-sub height {
- my $self = shift;
- return $self->{height} if exists $self->{height};
- my $baseheight = $self->option('height'); # what the factory says
- return $self->{height} = $baseheight;
-}
-sub width {
- my $self = shift;
- my $g = $self->{width};
- $self->{width} = shift if @_;
- $g;
-}
-sub layout_height {
- my $self = shift;
- return $self->layout;
-}
-sub layout_width {
- my $self = shift;
-# return $self->{layout_width} ||= $self->width + $self->pad_left + $self->pad_right;
- return $self->width + $self->pad_left + $self->pad_right;
-}
-
-# returns the rectangle that surrounds the physical part of the
-# glyph, excluding labels and other "extra" stuff
-sub calculate_boundaries {return shift->bounds(@_);}
-
-sub bounds {
- my $self = shift;
- my ($dx,$dy) = @_;
- $dx += 0; $dy += 0;
- ($dx + $self->{left},
- $dy + $self->top + $self->pad_top,
- $dx + $self->{left} + $self->{width} - 1,
- $dy + $self->bottom - $self->pad_bottom);
-}
-
-
-
-sub box {
- my $self = shift;
- return ($self->left,$self->top,$self->right,$self->bottom);
-}
-
-
-sub unfilled_box {
- my $self = shift;
- my $gd = shift;
- my ($x1,$y1,$x2,$y2) = @_;
-
- my $fg = $self->fgcolor;
- my $bg = $self->bgcolor;
- my $linewidth = $self->option('linewidth') || 1;
-
- $fg = $self->set_pen($linewidth,$fg) if $linewidth > 1;
-
- # draw a box
- $gd->rectangle($x1,$y1,$x2,$y2,$fg);
-
- # if the left end is off the end, then cover over
- # the leftmost line
- my ($width) = $gd->getBounds;
-
- $bg = $self->set_pen($linewidth,$bg) if $linewidth > 1;
-
- $gd->line($x1,$y1+$linewidth,$x1,$y2-$linewidth,$bg)
- if $x1 < $self->panel->pad_left;
-
- $gd->line($x2,$y1+$linewidth,$x2,$y2-$linewidth,$bg)
- if $x2 > $width - $self->panel->pad_right;
-}
-
-
-# return boxes surrounding each part
-sub boxes {
- my $self = shift;
- my ($left,$top) = @_;
- $top += 0; $left += 0;
- my @result;
-
- $self->layout;
- for my $part ($self->parts) {
- if (eval{$part->feature->primary_tag} eq 'group') {
- push @result,$part->boxes($left+$self->left,$top+$self->top);
- } else {
- my ($x1,$y1,$x2,$y2) = $part->box;
- push @result,[$part->feature,$x1,$top+$self->top+$y1,$x2,$top+$self->top+$y2];
- }
- }
- return wantarray ? @result : \@result;
-}
-
-# this should be overridden for labels, etc.
-# allows glyph to make itself thicker or thinner depending on
-# domain-specific knowledge
-sub pad_top {
- my $self = shift;
- return 0;
-}
-sub pad_bottom {
- my $self = shift;
- return 0;
-}
-sub pad_left {
- my $self = shift;
- return 0;
-}
-sub pad_right {
- my $self = shift;
-# this shouldn't be necessary
- my @parts = $self->parts or return 0;
- my $max = 0;
- foreach (@parts) {
- my $pr = $_->pad_right;
- $max = $pr if $max < $pr;
- }
- $max;
-}
-
-# move relative to parent
-sub move {
- my $self = shift;
- my ($dx,$dy) = @_;
- $self->{left} += $dx;
- $self->{top} += $dy;
-
- # because the feature parts use *absolute* not relative addressing
- # we need to move each of the parts horizontally, but not vertically
- $_->move($dx,0) foreach $self->parts;
-}
-
-# get an option
-sub option {
- my $self = shift;
- my $option_name = shift;
- my $factory = $self->factory;
- return unless $factory;
- $factory->option($self,$option_name,@{$self}{qw(partno total_parts)});
-}
-
-# set an option globally
-sub configure {
- my $self = shift;
- my $factory = $self->factory;
- my $option_map = $factory->option_map;
- while (@_) {
- my $option_name = shift;
- my $option_value = shift;
- ($option_name = lc $option_name) =~ s/^-//;
- $option_map->{$option_name} = $option_value;
- }
-}
-
-# some common options
-sub color {
- my $self = shift;
- my $color = shift;
- my $index = $self->option($color);
- # turn into a color index
- return $self->factory->translate_color($index) if defined $index;
- return 0;
-}
-
-sub connector {
- return shift->option('connector',@_);
-}
-
-# return value:
-# 0 no bumping
-# +1 bump down
-# -1 bump up
-sub bump {
- my $self = shift;
- return $self->option('bump');
-}
-
-# we also look for the "color" option for Ace::Graphics compatibility
-sub fgcolor {
- my $self = shift;
- my $index = $self->option('fgcolor') || $self->option('color') || return 0;
- $self->factory->translate_color($index);
-}
-
-#add for compatibility
-sub fillcolor {
- my $self = shift;
- return $self->bgcolor;
-}
-
-# we also look for the "background-color" option for Ace::Graphics compatibility
-sub bgcolor {
- my $self = shift;
- my $index = $self->option('fillcolor') || $self->option('bgcolor') || return 0;
- $self->factory->translate_color($index);
-}
-sub font {
- shift->option('font');
-}
-sub fontcolor {
- my $self = shift;
- $self->color('fontcolor') || $self->fgcolor;
-}
-sub font2color {
- my $self = shift;
- $self->color('font2color') || $self->fontcolor;
-}
-sub tkcolor { # "track color"
- my $self = shift;
- $self->option('tkcolor') or return;
- return $self->color('tkcolor')
-}
-sub connector_color {
- my $self = shift;
- $self->color('connector_color') || $self->fgcolor;
-}
-
-# handle collision detection
-sub layout {
- my $self = shift;
- return $self->{layout_height} if exists $self->{layout_height};
-
- (my @parts = $self->parts)
- || return $self->{layout_height} = $self->height + $self->pad_top + $self->pad_bottom;
-
- my $bump_direction = $self->bump;
-
- $_->layout foreach @parts; # recursively lay out
-
- if (@parts == 1 || !$bump_direction) {
- my $highest = 0;
- foreach (@parts) {
- my $height = $_->layout_height;
- $highest = $height > $highest ? $height : $highest;
- }
- return $self->{layout_height} = $highest + $self->pad_top + $self->pad_bottom;
- }
-
- my %occupied;
- for my $g (sort { $a->left <=> $b->left } @parts) {
-
- my $pos = 0;
-
- while (1) {
- # look for collisions
- my $bottom = $pos + $g->{layout_height};
-
- my $collision;
- for my $old (sort {$b->[2]<=> $a->[2]} values %occupied) {
- last if $old->[2] + 2 < $g->left;
- next if $old->[3] < $pos;
- next if $old->[1] > $bottom;
- $collision = $old;
- last;
- }
- last unless $collision;
-
- if ($bump_direction > 0) {
- $pos += $collision->[3]-$collision->[1] + BUMP_SPACING; # collision, so bump
-
- } else {
- $pos -= BUMP_SPACING;
- }
- }
- $g->move(0,$pos);
- $occupied{$g} = [$g->left,$g->top,$g->right,$g->bottom];
- }
-
- # If -1 bumping was allowed, then normalize so that the top glyph is at zero
- if ($bump_direction < 0) {
- my ($topmost) = sort {$a->top <=> $b->top} @parts;
- my $offset = 0 - $topmost->top;
- $_->move(0,$offset) foreach @parts;
- }
-
- # find new height
- my $bottom = 0;
- foreach (@parts) {
- $bottom = $_->bottom if $_->bottom > $bottom;
- }
- return $self->{layout_height} = $self->pad_bottom + $self->pad_top + $bottom - $self->top + 1;
-}
-
-sub draw {
- my $self = shift;
- my $gd = shift;
- my ($left,$top,$partno,$total_parts) = @_;
-
- local($self->{partno},$self->{total_parts});
- @{$self}{qw(partno total_parts)} = ($partno,$total_parts);
-
- my $connector = $self->connector;
- if (my @parts = $self->parts) {
- my $x = $left;
- my $y = $top + $self->top + $self->pad_top;
-
- my $last_x;
- for (my $i=0; $i<@parts; $i++) {
- # lie just a little bit to avoid lines overlapping and
- # make the picture prettier
- my $fake_x = $x;
- $fake_x-- if defined $last_x && $parts[$i]->left - $last_x == 1;
- $parts[$i]->draw($gd,$fake_x,$y,$i,scalar(@parts));
- $last_x = $parts[$i]->right;
- }
- $self->draw_connectors($gd,$x,$y) if $connector && $connector ne 'none';
- }
-
- else { # no part
- $self->draw_component($gd,$left,$top);
- $self->draw_connectors($gd,$left,$top)
- if $connector && $connector ne 'none' && !$self->is_recursive;
- }
-}
-
-sub draw_connectors {
- my $self = shift;
- my $gd = shift;
- my ($dx,$dy) = @_;
- my @parts = sort { $a->left <=> $b->left } $self->parts;
- for (my $i = 0; $i < @parts-1; $i++) {
- $self->_connector($gd,$dx,$dy,$parts[$i]->bounds,$parts[$i+1]->bounds);
- }
-
- # extra connectors going off ends
- if (@parts>1) {
- my($x1,$y1,$x2,$y2) = $self->bounds(0,0);
- my($xl,$xt,$xr,$xb) = $parts[0]->bounds;
- $self->_connector($gd,$dx,$dy,$x1,$xt,$x1,$xb,$xl,$xt,$xr,$xb);
- ($xl,$xt,$xr,$xb) = $parts[-1]->bounds;
- $self->_connector($gd,$dx,$dy,$parts[-1]->bounds,$x2,$xt,$x2,$xb);
- }
-
-}
-
-sub _connector {
- my $self = shift;
- my ($gd,$dx,$dy,$xl,$xt,$xr,$xb,$yl,$yt,$yr,$yb) = @_;
- my $left = $dx + $xr;
- my $right = $dx + $yl;
- my $top1 = $dy + $xt;
- my $bottom1 = $dy + $xb;
- my $top2 = $dy + $yt;
- my $bottom2 = $dy + $yb;
- return unless $right-$left > 1;
-
- $self->draw_connector($gd,
- $top1,$bottom1,$left,
- $top2,$bottom2,$right,
- );
-}
-
-sub draw_connector {
- my $self = shift;
- my $gd = shift;
-
- my $color = $self->connector_color;
- my $connector_type = $self->connector or return;
- if ($connector_type eq 'hat') {
- $self->draw_hat_connector($gd,$color,@_);
- } elsif ($connector_type eq 'solid') {
- $self->draw_solid_connector($gd,$color,@_);
- } elsif ($connector_type eq 'dashed') {
- $self->draw_dashed_connector($gd,$color,@_);
- } else {
- ; # draw nothing
- }
-}
-
-sub draw_hat_connector {
- my $self = shift;
- my $gd = shift;
- my $color = shift;
- my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
-
- my $center1 = ($top1 + $bottom1)/2;
- my $quarter1 = $top1 + ($bottom1-$top1)/4;
- my $center2 = ($top2 + $bottom2)/2;
- my $quarter2 = $top2 + ($bottom2-$top2)/4;
-
- if ($center1 != $center2) {
- $self->draw_solid_connector($gd,$color,@_);
- return;
- }
-
- if ($right - $left > 4) { # room for the inverted "V"
- my $middle = $left + int(($right - $left)/2);
- $gd->line($left,$center1,$middle,$top1,$color);
- $gd->line($middle,$top1,$right-1,$center1,$color);
- } elsif ($right-$left > 1) { # no room, just connect
- $gd->line($left,$quarter1,$right-1,$quarter1,$color);
- }
-
-}
-
-sub draw_solid_connector {
- my $self = shift;
- my $gd = shift;
- my $color = shift;
- my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
-
- my $center1 = ($top1 + $bottom1)/2;
- my $center2 = ($top2 + $bottom2)/2;
-
- $gd->line($left,$center1,$right,$center2,$color);
-}
-
-sub draw_dashed_connector {
- my $self = shift;
- my $gd = shift;
- my $color = shift;
- my ($top1,$bottom1,$left,$top2,$bottom2,$right) = @_;
-
- my $center1 = ($top1 + $bottom1)/2;
- my $center2 = ($top2 + $bottom2)/2;
-
- $gd->setStyle($color,$color,gdTransparent,gdTransparent,);
- $gd->line($left,$center1,$right,$center2,gdStyled);
-}
-
-sub filled_box {
- my $self = shift;
- my $gd = shift;
- my ($x1,$y1,$x2,$y2,$bg,$fg) = @_;
-
- $bg ||= $self->bgcolor;
- $fg ||= $self->fgcolor;
- my $linewidth = $self->option('linewidth') || 1;
-
- $gd->filledRectangle($x1,$y1,$x2,$y2,$bg);
-
- $fg = $self->set_pen($linewidth,$fg) if $linewidth > 1;
-
- # draw a box
- $gd->rectangle($x1,$y1,$x2,$y2,$fg);
-
- # if the left end is off the end, then cover over
- # the leftmost line
- my ($width) = $gd->getBounds;
-
- $bg = $self->set_pen($linewidth,$bg) if $linewidth > 1;
-
- $gd->line($x1,$y1+$linewidth,$x1,$y2-$linewidth,$bg)
- if $x1 < $self->panel->pad_left;
-
- $gd->line($x2,$y1+$linewidth,$x2,$y2-$linewidth,$bg)
- if $x2 > $width - $self->panel->pad_right;
-}
-
-sub filled_oval {
- my $self = shift;
- my $gd = shift;
- my ($x1,$y1,$x2,$y2,$bg,$fg) = @_;
- my $cx = ($x1+$x2)/2;
- my $cy = ($y1+$y2)/2;
-
- $fg ||= $self->fgcolor;
- $bg ||= $self->bgcolor;
- my $linewidth = $self->linewidth;
-
- $fg = $self->set_pen($linewidth) if $linewidth > 1;
- $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$fg);
-
- # and fill it
- $gd->fill($cx,$cy,$bg);
-}
-
-sub oval {
- my $self = shift;
- my $gd = shift;
- my ($x1,$y1,$x2,$y2) = @_;
- my $cx = ($x1+$x2)/2;
- my $cy = ($y1+$y2)/2;
-
- my $fg = $self->fgcolor;
- my $linewidth = $self->linewidth;
-
- $fg = $self->set_pen($linewidth) if $linewidth > 1;
- $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$fg);
-}
-
-sub filled_arrow {
- my $self = shift;
- my $gd = shift;
- my $orientation = shift;
-
- my ($x1,$y1,$x2,$y2) = @_;
-
- my ($width) = $gd->getBounds;
- my $indent = $y2-$y1 < $x2-$x1 ? $y2-$y1 : ($x2-$x1)/2;
-
- return $self->filled_box($gd,@_)
- if ($orientation == 0)
- or ($x1 < 0 && $orientation < 0)
- or ($x2 > $width && $orientation > 0)
- or ($indent <= 0)
- or ($x2 - $x1 < 3);
-
- my $fg = $self->fgcolor;
- if ($orientation >= 0) {
- $gd->line($x1,$y1,$x2-$indent,$y1,$fg);
- $gd->line($x2-$indent,$y1,$x2,($y2+$y1)/2,$fg);
- $gd->line($x2,($y2+$y1)/2,$x2-$indent,$y2,$fg);
- $gd->line($x2-$indent,$y2,$x1,$y2,$fg);
- $gd->line($x1,$y2,$x1,$y1,$fg);
- $gd->fillToBorder($x1+1,($y1+$y2)/2,$fg,$self->bgcolor);
- } else {
- $gd->line($x1,($y2+$y1)/2,$x1+$indent,$y1,$fg);
- $gd->line($x1+$indent,$y1,$x2,$y1,$fg);
- $gd->line($x2,$y2,$x1+$indent,$y2,$fg);
- $gd->line($x1+$indent,$y2,$x1,($y1+$y2)/2,$fg);
- $gd->line($x2,$y1,$x2,$y2,$fg);
- if ($x2 > 0 && $x2<=$self->panel->right) {
- $gd->fillToBorder($x2-1,($y1+$y2)/2,$fg,$self->bgcolor);
- }
- }
-}
-
-sub linewidth {
- shift->option('linewidth') || 1;
-}
-
-sub fill {
- my $self = shift;
- my $gd = shift;
- my ($x1,$y1,$x2,$y2) = @_;
- if ( ($x2-$x1) >= 2 && ($y2-$y1) >= 2 ) {
- $gd->fill($x1+1,$y1+1,$self->bgcolor);
- }
-}
-sub set_pen {
- my $self = shift;
- my ($linewidth,$color) = @_;
- $linewidth ||= $self->linewidth;
- $color ||= $self->fgcolor;
- return $color unless $linewidth > 1;
- $self->panel->set_pen($linewidth,$color);
-}
-
-sub draw_component {
- my $self = shift;
- my $gd = shift;
- my($x1,$y1,$x2,$y2) = $self->bounds(@_);
-
- # clipping
- my $panel = $self->panel;
- return unless $x2 >= $panel->left and $x1 <= $panel->right;
-
- if ($self->option('strand_arrow')) {
- $self->filled_arrow($gd,$self->feature->strand,
- $x1, $y1,
- $x2, $y2)
- } else {
- $self->filled_box($gd,
- $x1, $y1,
- $x2, $y2)
- }
-}
-
-# memoize _subseq -- it's a bottleneck with segments
-sub subseq {
- my $self = shift;
- my $feature = shift;
- return $self->_subseq($feature) unless ref $self;
- return @{$self->{cached_subseq}{$feature}} if $self->{cached_subseq}{$feature};
- my @ss = $self->_subseq($feature);
- $self->{cached_subseq}{$feature} = \@ss;
- @ss;
-}
-
-sub _subseq {
- my $class = shift;
- my $feature = shift;
- return $feature->merged_segments if $feature->can('merged_segments');
- return $feature->segments if $feature->can('segments');
- my @split = eval { my $id = $feature->location->seq_id;
- my @subs = $feature->location->sub_Location;
- grep {$id eq $_->seq_id} $feature->location->sub_Location};
- return @split if @split;
- return $feature->sub_SeqFeature if $feature->can('sub_SeqFeature');
- return;
-}
-
-# synthesize a key glyph
-sub keyglyph {
- my $self = shift;
- my $feature = $self->make_key_feature;
- my $factory = $self->factory->clone;
- $factory->set_option(label => 1);
- $factory->set_option(bump => 0);
- $factory->set_option(connector => 'solid');
- return $factory->make_glyph($feature);
-}
-
-# synthesize a key glyph
-sub make_key_feature {
- my $self = shift;
-
- my $scale = 1/$self->scale; # base pairs/pixel
-
- # one segments, at pixels 0->80
- my $offset = $self->panel->offset;
-
-
- my $feature =
- Bio::Graphics::Feature->new(-start =>0 * $scale +$offset,
- -end =>80*$scale+$offset,
- -name => $self->option('key'),
- -strand => '+1');
- return $feature;
-}
-
-sub all_callbacks {
- my $self = shift;
- my $track_level = $self->option('all_callbacks');
- return $track_level if defined $track_level;
- return $self->panel->all_callbacks;
-}
-
-sub default_factory {
- croak "no default factory implemented";
-}
-
-# This returns true if the underlying feature is fully recursive, like Bio::DB::GFF or
-# Gadfly, false if the underlying feature has split locations, like Bio::Seq::RichSeq.
-# Play with this if you start getting labels appearing on each element of a segmented
-# glyph.
-sub is_recursive {
- my $self = shift;
- return $self->{_recursive} if exists $self->{_recursive};
- return $self->{_recursive} = !$self->feature->isa('Bio::SeqFeature::Generic');
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Bio::Graphics::Glyph - Base class for Bio::Graphics::Glyph objects
-
-=head1 SYNOPSIS
-
-See L<Bio::Graphics::Panel>.
-
-=head1 DESCRIPTION
-
-Bio::Graphics::Glyph is the base class for all glyph objects. Each
-glyph is a wrapper around an Bio:SeqFeatureI object, knows how to
-render itself on an Bio::Graphics::Panel, and has a variety of
-configuration variables.
-
-End developers will not ordinarily work directly with
-Bio::Graphics::Glyph objects, but with Bio::Graphics::Glyph::generic
-and its subclasses. Similarly, most glyph developers will want to
-subclass from Bio::Graphics::Glyph::generic because the latter
-provides labeling and arrow-drawing facilities.
-
-=head1 METHODS
-
-This section describes the class and object methods for
-Bio::Graphics::Glyph.
-
-=head2 CONSTRUCTORS
-
-Bio::Graphics::Glyph objects are constructed automatically by an
-Bio::Graphics::Glyph::Factory, and are not usually created by
-end-developer code.
-
-=over 4
-
-=item $glyph = Bio::Graphics::Glyph->new(-feature=>$feature,-factory=>$factory)
-
-Given a sequence feature, creates an Bio::Graphics::Glyph object to
-display it. The B<-feature> argument points to the Bio:SeqFeatureI
-object to display, and B<-factory> indicates an
-Bio::Graphics::Glyph::Factory object from which the glyph will fetch
-all its run-time configuration information. Factories are created and
-manipulated by the Bio::Graphics::Panel object.
-
-A standard set of options are recognized. See L<OPTIONS>.
-
-=back
-
-=head2 OBJECT METHODS
-
-Once a glyph is created, it responds to a large number of methods. In
-this section, these methods are grouped into related categories.
-
-Retrieving glyph context:
-
-=over 4
-
-=item $factory = $glyph->factory
-
-Get the Bio::Graphics::Glyph::Factory associated with this object.
-This cannot be changed once it is set.
-
-=item $panel = $glyph->panel
-
-Get the Bio::Graphics::Panel associated with this object. This cannot
-be changed once it is set.
-
-=item $feature = $glyph->feature
-
-Get the sequence feature associated with this object. This cannot be
-changed once it is set.
-
-=item $feature = $glyph->add_feature(@features)
-
-Add the list of features to the glyph, creating subparts. This is
-most common done with the track glyph returned by
-Ace::Graphics::Panel->add_track().
-
-=item $feature = $glyph->add_group(@features)
-
-This is similar to add_feature(), but the list of features is treated
-as a group and can be configured as a set.
-
-=back
-
-Retrieving glyph options:
-
-=over 4
-
-=item $fgcolor = $glyph->fgcolor
-
-=item $bgcolor = $glyph->bgcolor
-
-=item $fontcolor = $glyph->fontcolor
-
-=item $fontcolor = $glyph->font2color
-
-=item $fillcolor = $glyph->fillcolor
-
-These methods return the configured foreground, background, font,
-alternative font, and fill colors for the glyph in the form of a
-GD::Image color index.
-
-=item $color = $glyph->tkcolor
-
-This method returns a color to be used to flood-fill the entire glyph
-before drawing (currently used by the "track" glyph).
-
-=item $width = $glyph->width([$newwidth])
-
-Return the width of the glyph, not including left or right padding.
-This is ordinarily set internally based on the size of the feature and
-the scale of the panel.
-
-=item $width = $glyph->layout_width
-
-Returns the width of the glyph including left and right padding.
-
-=item $width = $glyph->height
-
-Returns the height of the glyph, not including the top or bottom
-padding. This is calculated from the "height" option and cannot be
-changed.
-
-
-=item $font = $glyph->font
-
-Return the font for the glyph.
-
-=item $option = $glyph->option($option)
-
-Return the value of the indicated option.
-
-=item $index = $glyph->color($color)
-
-Given a symbolic or #RRGGBB-form color name, returns its GD index.
-
-=back
-
-Setting an option:
-
-=over 4
-
-=item $glyph->configure(-name=>$value)
-
-You may change a glyph option after it is created using set_option().
-This is most commonly used to configure track glyphs.
-
-=back
-
-Retrieving information about the sequence:
-
-=over 4
-
-=item $start = $glyph->start
-
-=item $end = $glyph->end
-
-These methods return the start and end of the glyph in base pair
-units.
-
-=item $offset = $glyph->offset
-
-Returns the offset of the segment (the base pair at the far left of
-the image).
-
-=item $length = $glyph->length
-
-Returns the length of the sequence segment.
-
-=back
-
-
-Retrieving formatting information:
-
-=over 4
-
-=item $top = $glyph->top
-
-=item $left = $glyph->left
-
-=item $bottom = $glyph->bottom
-
-=item $right = $glyph->right
-
-These methods return the top, left, bottom and right of the glyph in
-pixel coordinates.
-
-=item $height = $glyph->height
-
-Returns the height of the glyph. This may be somewhat larger or
-smaller than the height suggested by the GlyphFactory, depending on
-the type of the glyph.
-
-=item $scale = $glyph->scale
-
-Get the scale for the glyph in pixels/bp.
-
-=item $height = $glyph->labelheight
-
-Return the height of the label, if any.
-
-=item $label = $glyph->label
-
-Return a human-readable label for the glyph.
-
-=back
-
-These methods are called by Bio::Graphics::Track during the layout
-process:
-
-=over 4
-
-=item $glyph->move($dx,$dy)
-
-Move the glyph in pixel coordinates by the indicated delta-x and
-delta-y values.
-
-=item ($x1,$y1,$x2,$y2) = $glyph->box
-
-Return the current position of the glyph.
-
-=back
-
-These methods are intended to be overridden in subclasses:
-
-=over 4
-
-=item $glyph->calculate_height
-
-Calculate the height of the glyph.
-
-=item $glyph->calculate_left
-
-Calculate the left side of the glyph.
-
-=item $glyph->calculate_right
-
-Calculate the right side of the glyph.
-
-=item $glyph->draw($gd,$left,$top)
-
-Optionally offset the glyph by the indicated amount and draw it onto
-the GD::Image object.
-
-
-=item $glyph->draw_label($gd,$left,$top)
-
-Draw the label for the glyph onto the provided GD::Image object,
-optionally offsetting by the amounts indicated in $left and $right.
-
-=back
-
-These methods are useful utility routines:
-
-=over 4
-
-=item $pixels = $glyph->map_pt($bases);
-
-Map the indicated base position, given in base pair units, into
-pixels, using the current scale and glyph position.
-
-=item $glyph->filled_box($gd,$x1,$y1,$x2,$y2)
-
-Draw a filled rectangle with the appropriate foreground and fill
-colors, and pen width onto the GD::Image object given by $gd, using
-the provided rectangle coordinates.
-
-=item $glyph->filled_oval($gd,$x1,$y1,$x2,$y2)
-
-As above, but draws an oval inscribed on the rectangle.
-
-=back
-
-=head2 OPTIONS
-
-The following options are standard among all Glyphs. See individual
-glyph pages for more options.
-
- 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
-
- -strand_arrow Whether to indicate 0 (false)
- strandedness
-
- -label Whether to draw a label 0 (false)
-
- -description Whether to draw a description 0 (false)
-
-For glyphs that consist of multiple segments, the -connector option
-controls what's drawn between the segments. The default is 0 (no
-connector). Options include "hat", an upward-angling conector,
-"solid", a straight horizontal connector, and "dashed", for a
-horizontal dashed line. The -connector_color option controls the
-color of the connector, if any.
-
-The label is printed above the glyph. You may pass an anonymous
-subroutine to -label, in which case the subroutine will be invoked
-with the feature as its single argument. The subroutine must return a
-string to render as the label. Otherwise, you may return the number
-"1", in which case the feature's info(), seqname() and primary_tag()
-methods will be called (in that order) until a suitable name is found.
-
-The description is printed below the glyph. You may pass an anonymous
-subroutine to -label, in which case the subroutine will be invoked
-with the feature as its single argument. The subroutine must return a
-string to render as the label. Otherwise, you may return the number
-"1", in which case the feature's source_tag() method will be invoked.
-
-In the case of ACEDB Ace::Sequence feature objects, the feature's
-info(), Brief_identification() and Locus() methods will be called to
-create a suitable description.
-
-The -strand_arrow option, if true, requests that the glyph indicate
-which strand it is on, usually by drawing an arrowhead. Not all
-glyphs can respond appropriately to this request.
-
-=head1 SUBCLASSING Bio::Graphics::Glyph
-
-By convention, subclasses are all lower-case. Begin each subclass
-with a preamble like this one:
-
- package Bio::Graphics::Glyph::crossbox;
-
- use strict;
- use vars '@ISA';
- @ISA = 'Bio::Graphics::Glyph';
-
-Then override the methods you need to. Typically, just the draw()
-method will need to be overridden. However, if you need additional
-room in the glyph, you may override calculate_height(),
-calculate_left() and calculate_right(). Do not directly override
-height(), left() and right(), as their purpose is to cache the values
-returned by their calculating cousins in order to avoid time-consuming
-recalculation.
-
-A simple draw() method looks like this:
-
- sub draw {
- my $self = shift;
- $self->SUPER::draw(@_);
- my $gd = shift;
-
- # and draw a cross through the box
- my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
- my $fg = $self->fgcolor;
- $gd->line($x1,$y1,$x2,$y2,$fg);
- $gd->line($x1,$y2,$x2,$y1,$fg);
- }
-
-This subclass draws a simple box with two lines criss-crossed through
-it. We first call our inherited draw() method to generate the filled
-box and label. We then call calculate_boundaries() to return the
-coordinates of the glyph, disregarding any extra space taken by
-labels. We call fgcolor() to return the desired foreground color, and
-then call $gd->line() twice to generate the criss-cross.
-
-For more complex draw() methods, see Bio::Graphics::Glyph::transcript
-and Bio::Graphics::Glyph::segments.
-
-=head1 BUGS
-
-Please report them.
-
-=head1 SEE ALSO
-
-L<Bio::DB::GFF::Feature>,
-L<Ace::Sequence>,
-L<Bio::Graphics::Panel>,
-L<Bio::Graphics::Track>,
-L<Bio::Graphics::Glyph::anchored_arrow>,
-L<Bio::Graphics::Glyph::arrow>,
-L<Bio::Graphics::Glyph::box>,
-L<Bio::Graphics::Glyph::dna>,
-L<Bio::Graphics::Glyph::graded_segments>,
-L<Bio::Graphics::Glyph::primers>,
-L<Bio::Graphics::Glyph::segments>,
-L<Bio::Graphics::Glyph::toomany>,
-L<Bio::Graphics::Glyph::transcript>,
-L<Bio::Graphics::Glyph::transcript2>,
-L<Bio::Graphics::Glyph::wormbase_transcript>
-
-=head1 AUTHOR
-
-Lincoln Stein <lstein@cshl.org>.
-
-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
View
151 Graphics/Glyph/Factory.pm
@@ -1,151 +0,0 @@
-package Bio::Graphics::Glyph::Factory;
-
-use strict;
-use Carp qw(:DEFAULT cluck);
-use GD;
-
-my %LOADED_GLYPHS = ();
-my %GENERIC_OPTIONS = (
- bgcolor => 'turquoise',
- fgcolor => 'black',
- fontcolor => 'black',
- font2color => 'turquoise',
- height => 8,
- font => gdSmallFont,
- bump => +1, # bump by default (perhaps a mistake?)
- );
-
-sub new {
- my $class = shift;
- my $panel = shift;
- my %args = @_;
- my $stylesheet = $args{-stylesheet}; # optional, for Bio::Das compatibility
- my $map = $args{-map}; # map type name to glyph name
- my $options = $args{-options}; # map type name to glyph options
- return bless {
- stylesheet => $stylesheet,
- glyph_map => $map,
- options => $options,
- panel => $panel,
- },$class;
-}
-sub clone {
- my $self = shift;
- my %new = %$self;
- my $new = bless \%new,ref($self);
- $new;
-}
-sub stylesheet { shift->{stylesheet} }
-sub glyph_map { shift->{glyph_map} }
-sub option_map { shift->{options} }
-sub global_opts{ shift->{global_opts} }
-sub panel { shift->{panel} }
-sub scale { shift->{panel}->scale }
-sub font {
- my $self = shift;
- my $glyph = shift;
- $self->option($glyph,'font') || $self->{font};
-}
-
-sub map_pt {
- my $self = shift;
- my @result = $self->panel->map_pt(@_);
- return wantarray ? @result : $result[0];
-}
-
-sub translate_color {
- my $self = shift;
- my $color_name = shift;
- $self->panel->translate_color($color_name);
-}
-
-# create a glyph
-sub make_glyph {
- my $self = shift;
- my @result;
- my $panel = $self->panel;
- my ($leftmost,$rightmost) = ($panel->left,$panel->right);
-
- for my $f (@_) {
-
- my $type = $self->feature_to_glyph($f);
- my $glyphclass = 'Bio::Graphics::Glyph';
- $type ||= 'generic';
- $glyphclass .= "\:\:\L$type";
-
- unless ($LOADED_GLYPHS{$glyphclass}++) {
- carp("the requested glyph class, ``$type'' is not available: $@")
- unless (eval "require $glyphclass");
- }
- my $glyph = $glyphclass->new(-feature => $f,
- -factory => $self);
-
- # this is removing glyphs that are not onscreen at all.
- # But never remove tracks!
- push @result,$glyph if $type eq 'track'
- || ($glyph->{left} + $glyph->{width} > $leftmost && $glyph->{left} < $rightmost);
- }
- return wantarray ? @result : $result[0];
-}
-
-sub feature_to_glyph {
- my $self = shift;
- my $feature = shift;
-
- return scalar $self->{stylesheet}->glyph($feature) if $self->{stylesheet};
- my $map = $self->glyph_map or return 'generic';
- return $map->($feature) || 'generic' if ref($map) eq 'CODE';
- return $map->{$feature->primary_tag} || 'generic';
-}
-
-sub set_option {
- my $self = shift;
- my ($option_name,$option_value) = @_;
- $self->{overriding_options}{lc $option_name} = $option_value;
-}
-
-# options:
-# the overriding_options hash has precedence
-# ...followed by the option_map
-# ...followed by the stylesheet
-# ...followed by generic options
-sub option {
- my $self = shift;
- my ($glyph,$option_name,$partno,$total_parts) = @_;
- return unless defined $option_name;
- $option_name = lc $option_name; # canonicalize
-
- return $self->{overriding_options}{$option_name}
- if exists $self->{overriding_options} && exists $self->{overriding_options}{$option_name};
-
- if (my $map = $self->option_map) {
- if (defined(my $value = $map->{$option_name})) {
- my $feature = $glyph->feature;
- return $value unless ref $value eq 'CODE';
- return unless $feature->isa('Bio::SeqFeatureI');
- my $val = $value->($feature,$option_name,$partno,$total_parts);
- return defined $val && $val eq '*default*' ? $GENERIC_OPTIONS{$option_name} : $val;
- }
- }
-
- if (my $ss = $self->stylesheet) {
- my($glyph,%options) = $ss->glyph($glyph->feature);
- my $value = $options{$option_name};
- return $value if defined $value;
- }
-
- return $GENERIC_OPTIONS{$option_name};
-}
-
-# return names of all the options in the option hashes
-sub options {
- my $self = shift;
- my %options;
- if (my $map = $self->option_map) {
- $options{lc($_)}++ foreach keys %$map;
- }
- $options{lc($_)}++ foreach keys %GENERIC_OPTIONS;
- return keys %options;
-}
-
-1;
View
103 Graphics/Glyph/alignment.pm
@@ -1,103 +0,0 @@
-package Bio::Graphics::Glyph::alignment;
-
-use strict;
-
-use Bio::Graphics::Glyph::graded_segments;
-use vars '@ISA';
-@ISA = 'Bio::Graphics::Glyph::graded_segments';
-
-1;
-
-__END__
-
-=head1 NAME
-
-Bio::Graphics::Glyph::alignment - The "alignment" glyph
-
-=head1 SYNOPSIS
-
- See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
-
-=head1 DESCRIPTION
-
-This is identical to the "graded_segments" glyph, and is used for
-drawing features that consist of discontinuous segments. The
-color intensity of each segment is proportionate to the score.
-
-=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)
-
- -strand_arrow Whether to indicate 0 (false)
- strandedness
-
-
-In addition, the alignment glyph recognizes the following
-glyph-specific options:
-
- Option Description Default
- ------ ----------- -------
-
- -max_score Maximum value of the Calculated
- feature's "score" attribute
-
- -min_score Minimum value of the Calculated
- feature's "score" attribute
-
-If max_score and min_score are not specified, then the glyph will
-calculate the local maximum and minimum scores at run time.
-
-
-=head1 BUGS
-
-Please report them.
-
-=head1 SEE ALSO
-
-L<Ace::Sequence>, L<Ace::Sequence::Feature>, L<Bio::Graphics::Panel>,
-L<Bio::Graphics::Track>, L<Bio::Graphics::Glyph::anchored_arrow>,
-L<Bio::Graphics::Glyph::arrow>,
-L<Bio::Graphics::Glyph::box>,
-L<Bio::Graphics::Glyph::primers>,
-L<Bio::Graphics::Glyph::segments>,
-L<Bio::Graphics::Glyph::toomany>,
-L<Bio::Graphics::Glyph::transcript>,
-
-=head1 AUTHOR
-
-Allen Day <day@cshl.org>.
-
-Copyright (c) 2001 Cold Spring Harbor Laboratory
-
-This library is free software; you can redistribute it and/or modify