Permalink
Browse files

This commit was manufactured by cvs2svn to create tag

'bioperl-release-1-0-1'.

svn path=/bioperl-live/tags/bioperl-release-1-0-1/; revision=4103
  • Loading branch information...
1 parent 34631e5 commit 2e1bcb2e4ab3e50c3631dd4ad04c5ba208884897 nobody committed Jun 11, 2002
Showing with 0 additions and 317 deletions.
  1. +0 −156 Bio/DB/GFF/Adaptor/biofetch.pm
  2. +0 −161 Bio/Graphics/Glyph/heterogeneous_segments.pm
View
156 Bio/DB/GFF/Adaptor/biofetch.pm
@@ -1,156 +0,0 @@
-package Bio::DB::GFF::Adaptor::biofetch;
-
-=head1 NAME
-
-Bio::DB::GFF::Adaptor::biofetch -- Cache BioFetch objects in a Bio::DB::GFF database
-
-=head1 SYNOPSIS
-
-Proof of principle. Not for production use.
-
-=head1 DESCRIPTION
-
-This adaptor is a proof-of-principle. It is used to fetch BioFetch
-sequences into a Bio::DB::GFF database (currently uses a hard-coded
-mysqlopt database) as needed. This allows the Generic Genome Browser
-to be used as a Genbank/EMBL browser.
-
-=head1 AUTHOR
-
-Lincoln Stein E<lt>lstein@cshl.orgE<gt>.
-
-Copyright 2002 Cold Spring Harbor Laboratory.
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
-use strict;
-use Bio::DB::GFF::Adaptor::dbi::mysqlopt;
-use Bio::DB::BioFetch;
-
-use vars qw($VERSION @ISA);
-@ISA = qw(Bio::DB::GFF::Adaptor::dbi::mysqlopt);
-$VERSION = 0.10;
-
-sub segment {
- my $self = shift;
- my @segments = $self->SUPER::segment(@_);
-
- if (!@segments) {
- my $refclass = $self->refclass;
-
- my %args = $self->setup_segment_args(@_);
- if ($args{-class} && $args{-class} =~ /$refclass/oi) {
- return unless $self->load_from_embl('embl'=>$args{-name});
- @segments = $self->SUPER::segment(@_);
- } elsif ($args{-class} && $args{-class} =~ /refseq|swall|embl/i) { #hack to get refseq names
- return unless $self->load_from_embl(lc($args{-class})=>$args{-name});
- $args{-class} = $self->refclass;
- @segments = $self->SUPER::segment(%args);
- }
- }
-
- $self->_multiple_return_args(@segments);
-}
-
-# default is to return 'Sequence' as the class of all references
-sub refclass {
- my $self = shift;
- my $refname = shift;
- 'Accession';
-}
-
-sub load_from_embl {
- my $self = shift;
- my $db = shift;
- my $acc = shift or $self->throw('Must provide an accession ID');
- my $biofetch = $self->{_biofetch}{$db} ||= Bio::DB::BioFetch->new(-db=>$db);
- my $seq = eval {$biofetch->get_Seq_by_id($acc)} or return;
- my $refclass = $self->refclass;
-
- # begin loading
- $self->setup_load();
-
- # first synthesize the entry for the top-level feature
- my @aliases;
- foreach ($seq->accession,$seq->get_secondary_accessions) {
- next if lc($_) eq lc($acc);
- push @aliases,[Alias => $_];
- }
- $self->load_gff_line(
- {
- ref => $acc,
- class => $refclass,
- source => 'EMBL',
- method => 'origin',
- start => $seq->start,
- stop => $seq->end,
- score => undef,
- strand => '.',
- phase => '.',
- gclass => $self->refclass,
- gname => $acc,
- tstart => undef,
- tstop => undef,
- attributes => [[Note => $seq->desc],@aliases],
- }
- );
- # now load each feature in turn
- for my $feat ($seq->all_SeqFeatures) {
- my $attributes = $self->get_attributes($feat);
- my $first = (shift @$attributes);
-
- my $location = $feat->location;
- my @segments = map {[$_->start,$_->end]}
- $location->can('sub_Location') ? $location->sub_Location : $location;
-
- for my $segment (@segments) {
-
- $self->load_gff_line( {
- ref => $acc,
- class => $refclass,
- source => 'EMBL',
- method => $feat->primary_tag,
- start => $segment->[0],
- stop => $segment->[1],
- score => $feat->score || undef,
- strand => $feat->strand > 0 ? '+' : ($feat->strand < 0 ? '-' : '.'),
- phase => $feat->frame || '.',
- gclass => $first->[0],
- gname => $first->[1],
- tstart => undef,
- tstop => undef,
- attributes => $attributes,
- }
- );
- }
- }
-
- # finish loading
- $self->finish_load();
-
- # now load the DNA
- $self->load_sequence_string($acc,$seq->seq);
-
- 1;
-}
-
-sub get_attributes {
- my $self = shift;
- my $seq = shift;
-
- my @tags = $seq->all_tags or return;
- my @result;
- foreach my $tag (@tags) {
- foreach my $value ($seq->each_tag_value($tag)) {
- push @result,[$tag=>$value];
- }
- }
- \@result;
-}
-
-
-
-1;
View
161 Bio/Graphics/Glyph/heterogeneous_segments.pm
@@ -1,161 +0,0 @@
-package Bio::Graphics::Glyph::heterogeneous_segments;
-
-# this glyph acts like graded_segments but the bgcolor of each segment is
-# controlled by the source field of the feature. Use the source field name
-# to set the background color:
-# -waba_strong => 'blue'
-# -waba_weak => 'red'
-# -waba_coding => 'green'
-
-use strict;
-use Bio::Graphics::Glyph::graded_segments;
-use vars '@ISA';
-@ISA = 'Bio::Graphics::Glyph::graded_segments';
-
-# override draw method to calculate the min and max values for the components
-sub draw {
- my $self = shift;
-
- # bail out if this isn't the right kind of feature
- # handle both das-style and Bio::SeqFeatureI style,
- # which use different names for subparts.
- my @parts = $self->parts;
- return $self->SUPER::draw(@_) unless @parts;
-
- # figure out the colors
- $self->{source2color} ||= {};
- my $fill = $self->bgcolor;
- for my $part (@parts) {
- my $s = eval { $part->feature->source_tag } or next;
- $self->{source2color}{$s} ||= $self->color(lc($s)."_color") || $fill;
- $part->{partcolor} = $self->{source2color}{$s};
- }
-
- $self->Bio::Graphics::Glyph::generic::draw(@_);
-}
-
-
-# synthesize a key glyph
-sub keyglyph {
- my $self = shift;
-
- my $scale = 1/$self->scale; # base pairs/pixel
-
- # two segments, at pixels 0->50, 60->80
- my $offset = $self->panel->offset;
-
- my $feature =
- Bio::Graphics::Feature->new(
- -segments=>[ [ 0*$scale +$offset,25*$scale+$offset],
- [ 25*$scale +$offset,50*$scale+$offset],
- [ 50*$scale+$offset, 75*$scale+$offset]
- ],
- -name => $self->option('key'),
- -strand => '+1');
- my @sources = grep {/_color$/} $self->factory->options;
- foreach (@sources) {s/_color$//}
- ($feature->segments)[0]->source_tag($sources[1]);
- ($feature->segments)[1]->source_tag($sources[0]);
- ($feature->segments)[2]->source_tag($sources[2]);
- my $factory = $self->factory->clone;
- $factory->set_option(label => 1);
- $factory->set_option(bump => 0);
- $factory->set_option(connector => 'solid');
- my $glyph = $factory->make_glyph(0,$feature);
- return $glyph;
-}
-
-# component draws a shaded box
-sub draw_component {
- my $self = shift;
- my $gd = shift;
- my ($left,$top) = @_;
- my $color = $self->{partcolor};
- my @rect = $self->bounds(@_);
- $self->filled_box($gd,@rect,$color,$color);
-}
-
-1;
-
-=head1 NAME
-
-Bio::Graphics::Glyph::heterogeneous_segments - The "heterogeneous_segments" glyph
-
-=head1 SYNOPSIS
-
- See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
-
-=head1 DESCRIPTION
-
-This glyph acts like graded_segments but the bgcolor of each segment (sub-feature)
-can be individually set using the source field of the feature.
-
-Each segment type color is specified using the following nomenclature:
-
- -{source}_color => $color
-
-For example, if the feature consists of a gene containing both
-confirmed and unconfirmed exons, you can make the confirmed exons
-green and the unconfirmed ones red this way:
-
- -confirmed_color => 'green',
- -unconfirmed_color => 'red'
-
-=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)
-
-=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::graded_segments>,
-L<Bio::Graphics::Glyph::toomany>,
-L<Bio::Graphics::Glyph::transcript>,
-
-=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

0 comments on commit 2e1bcb2

Please sign in to comment.