From 9d71b4053bbe1e71ed9b9b65e946c291d816538d Mon Sep 17 00:00:00 2001 From: mwilkinson Date: Thu, 17 May 2001 14:53:40 +0000 Subject: [PATCH] replacing SeqCanvas version 1 with version 2. See message following for details on the changes svn path=/bioperl-gui/trunk/; revision=714 --- Bio/Tk/BioTkPerl8_2.pm | 4 + Bio/Tk/SeqCanvas.pm | 1489 +++++++++++++++++++++++++--------------- 2 files changed, 948 insertions(+), 545 deletions(-) create mode 100644 Bio/Tk/BioTkPerl8_2.pm diff --git a/Bio/Tk/BioTkPerl8_2.pm b/Bio/Tk/BioTkPerl8_2.pm new file mode 100644 index 0000000..be83610 --- /dev/null +++ b/Bio/Tk/BioTkPerl8_2.pm @@ -0,0 +1,4 @@ +package BioTkPerl8_2; + +1; + diff --git a/Bio/Tk/SeqCanvas.pm b/Bio/Tk/SeqCanvas.pm index 935c45b..586692d 100644 --- a/Bio/Tk/SeqCanvas.pm +++ b/Bio/Tk/SeqCanvas.pm @@ -1,14 +1,14 @@ -# $Id$ -=head2 NAME +# $Id$ +=head1 NAME -Bio::Tk::SeqCanvas.pm - Graphical display of SeqI compliant objects +Bio::Tk::SeqCanvas.pm - (v2.0) Graphical display of SeqI objects -=head2 AUTHORS +=head1 AUTHORS Mark Wilkinson (mwilkinson@gene.pbi.nrc.ca), David Block (dblock@gene.pbi.nrc.ca) Plant Biotechnology Institute, National Research Council of Canada. -Copyright (c) National Research Council of Canada, October, 2000. +Copyright (c) National Research Council of Canada, May, 2001. =head2 DISCLAIMER @@ -20,85 +20,74 @@ or merchantability or fitness for a particular purpose. NRC shall not be liable in any event for any damages, whether direct or indirect, consequential or incidental, arising from the use of the software. -=head2 SYNOPSIS - - # To create a BioSeq map and return a handle to the map object: - - use Tk; - use Bio::SeqIO; - use SeqCanvas; - # you may need to have a "use lib" statement here if you are running - # from the cvs version of bioperl-gui. - - Begin(); - MainLoop; - - sub Begin { - - # set up the Tk Windows - my $MW = MainWindow->new (-title => "Map Of BioSeq Object"); - my $Frame = $MW->Frame()->pack(-side => 'top'); - my $lblSysMess = $MW->Label()->pack(-side => 'bottom', -fill => 'both'); - - # create a BioSeq object - my $SIO = Bio::SeqIO->new(-file=> 'genbankfile.gb', -format => 'GenBank'); - my $SeqObj = $SIO->next_seq(); - - my $axis_length = 800; # how large I want the final map to be - - # Draw the Map - - $MapObj = Bio::Tk::SeqCanvas->new( - $axis_length, - $Frame, - $lblSysMess, - $SeqObj, - -orientation => 'horizontal', - label => 'primary_id', - AdditionalSources => ["test1", "test2", "test3"], - ); - - # SeqCanvas returns object reference for success - # returns -1 for failed initiation - no $SeqObj supplied - # returns -2 for bad sequence object - # returns -3 sequence has length 0 - # returns -4 if orientation is uninterpretable - # returns -5 if supplied frame object is not a TK::frame - - } - - =head2 DESCRIPTION and ACKNOWLEDGEMENTS Creates an interactive scalable/zoomable map of all features and -subfeatures of a Bio::SeqI compliant object. Basic functionality for -selecting single and multiple map objects is inherent in the object +subfeatures of Bio::SeqI compliant and GeneStructureI compliant objects. +Selecting single and multiple map objects is handled in the object itself: left-mouse click to select, SHIFT-left-mouse to select multiple. All other Tk Events are passed back up to the MainWindow object and can be trapped/bound by the user as they see fit. Colors and axis-offsets of mapped objects are assigned based on the "source" -tag of the feature object. These are assigned "on the fly" based on -whatever is contained in the BioSeq object provided. +tag of SeqFeature::Generic objects, and by the ordinal transcript number +of Gene:;TranscriptI compliant objects. These are assigned "on the fly" based on +whatever is contained in the BioSeq object provided. The maps re-size +on the fly to accomodate newly added features. This module requires an updated version of Gregg Helt's original -BioTkPerl modules(version 0.81) which are available from BioPerl. The +BioTkPerl modules (version 0.82) which are available from BioPerl. The original BioTkPerl (version 0.80) is Copyright (c) Gregg Helt, 1995; -Version 0.81 was generated by Mark Wilkinson, PBI-NRC, Oct., 2000. +Version 0.82 was generated by Mark Wilkinson, PBI-NRC, May., 2001. Zooming routines/events in this module are conceptually based on the Zoom routines from Genotator (Copyright (c) 1996, The Regents of the University of California. Harris, N.L. (1997), Genome Research -7(7):754-762) +7 (7):754-762) =head2 CONTACT Mark Wilkinson (mwilkinson@gene.pbi.nrc.ca) and Dave Block (dblock@gene.pbi.nrc.ca) -=head2 APPENDIX +=head1 SYNOPSIS -Description of Object tags, SeqCanvas Methods, and trapping Mouse events. + # To create a BioSeq map and return a handle to the map object: + use Tk; + use Bio::SeqIO; + use Bio::SeqFeature::Gene::Exon; + use Bio::SeqFeature::Gene::Transcript; + use Bio::SeqFeature::Gene::GeneStructure; + use SeqCanvas2; + Begin(); + MainLoop; -=head2 Object Tags: + sub Begin { + + # set up the Tk Windows + + my $MW = MainWindow->new (-title => "Map Of BioSeq Object"); + my $Frame = $MW->Frame()->pack(-side => 'top'); + my $Frame2 = $MW->Frame()->pack(-side => 'top'); + my $lblSysMess = $MW->Label()->pack(-side => 'bottom', -fill => 'both'); + + # create a BioSeq object + + my $SIO = Bio::SeqIO->new(-file=> 'genbankfile.gb', -format => 'genbank'); + my $SeqObj = $SIO->next_seq(); + + # Draw the Map + my $axis_length = 800; # how large I want the final map to be + $MapObj = Bio::Tk::SeqCanvas2->new( + $axis_length, + $Frame, + $lblSysMess, + $SeqObj, + -orientation => 'horizontal', + label => 'primary_tag', + width => 200, + ); + } + +=head1 WIDGET TAGS Each map-widget has several "reliable" tags attached to it. These tags are FIDxxxx, Source and Strand, Type, and Canvas, where: @@ -153,7 +142,92 @@ GeneMarkHMM" not just "GeneMarkHMM") =cut +=head1 CODE EXAMPLES: Adding/Binding Features + + SeqCanvas is a dynamic map, allowing features to be added or removed + after the object has been created. In addition, events occurring + on this canvas can be externally bound and assigned to subroutines + to allow the canvas to feed information out to an external program + for further processing. + + Some code examples are below; these can be added into the Begin() + subroutine in the synopsis to see how they work: + + # MAPPING SIMPLE GENERIC FEATURES + #________________________________ + # make six arbitrary features and map them + # if this is added into the Synopsis routine + # you will see that these features are labelled + # using their "author" tag values + my $x = 1; + while ($x < 6){ + my $feat = new Bio::SeqFeature::Generic ( + -start => 5000*$x, + -end => 6000*$x, + -strand => -1, + -primary => 'Unusual_feature', + -source => "example$x", + -score => 1000, + -tag => {new => 1, + author => 'someone_$x', + sillytag => 'this is silly!'} + ); + my ($FID) = $MapObj->mapFeatures(undef, [$feat]); + ++$x; + } + + # MAPPING GeneStructureI COMPLIANT FEATURES + #__________________________________________ + # first create the feature + my $exon1 = new Bio::SeqFeature::Gene::Exon (-start => 3300, -end => 4000, -primary_tag => "exon", -source => "genscan", -strand => -1); + my $exon2 = new Bio::SeqFeature::Gene::Exon (-start => 4400, -end => 6000, -primary_tag => "exon", -source => "genscan", -strand => -1); + my $exon3 = new Bio::SeqFeature::Gene::Exon (-start => 3000, -end => 4000, -primary_tag => "exon", -source => "genemark", -strand => -1); + my $exon4 = new Bio::SeqFeature::Gene::Exon (-start => 5000, -end => 6000, -primary_tag => "exon", -source => "genemark", -strand => -1); + my $polyA = Bio::SeqFeature::Generic->new(-start => 2500, -end => 2800, -primary_tag=> "polyA", -source => "polyA-scan", -strand => -1); + my $prom = Bio::SeqFeature::Generic->new(-start => 6200, -end => 6500, -primary_tag=> "promoter", -source => "prom-find", -strand => -1); + my $transcript = Bio::SeqFeature::Gene::Transcript->new(-start => 2500, -end => 6500, -primary_tag => "transcript", -source => "transcript", -strand => -1); + my $transcript2 = Bio::SeqFeature::Gene::Transcript->new(-start => 2500, -end => 6500, -primary_tag => "transcript", -source => "transcript", -strand => -1); + $transcript->add_promoter($prom); + $transcript->add_exon($exon1, 'initial'); + $transcript->add_exon($exon2, 'terminal'); + $transcript->poly_A_site($polyA); + $transcript->source_tag("cDNA_evidence"); + $transcript2->add_promoter($prom); + $transcript2->add_exon($exon3, 'initial'); + $transcript2->add_exon($exon4, 'terminal'); + $transcript2->poly_A_site($polyA); + $transcript2->source_tag("EST_evidence"); + my $Gene = Bio::SeqFeature::Gene::GeneStructure->new(-start => 2500, -end => 6500, -strand => -1, -primary_tag => "Gene", -source => "mark"); + $Gene->add_transcript($transcript); + $Gene->add_transcript($transcript2); + #$Gene->add_transcript($transcript8); + $SeqObj->add_SeqFeature($Gene); + my ($FID) = $MapObj->mapFeatures(undef, [$Gene]); + + + # BINDING EVENTS + #_______________ + # usually you will want to bind events to the + # MainWindow ($MW) object. + # + + $MW->bind("" => sub { + my ($FID, $strand, $source, $type, $canvas, $DB_ID) = $MapObj->getSelectedTags; + print "Feature ID = $FID\n"; + print "Source = $source\n"; + print "Primary_tag = $type\n"; + print "Strand = $strand\n\n"; + }); + + $MW->bind("" => sub { + my @FIDs = @{$MapObj->getIDsWithTag(["Mouse_over"])}; + # do whatever here, for example: + # foreach my $ID(@FIDs){print "id=$ID\n"} + }); + +=cut + package Bio::Tk::SeqCanvas; use strict; use Tk; @@ -162,7 +236,7 @@ use Bio::Tk::AnnotMap; use Tk::widgets qw(ColorEditor); use Bio::SeqI; use vars qw(@ISA $AUTOLOAD); -require Bio::Tk::BioTkPerl8_1; # requires version 0.81 of Gregg Helt's Bio::TkPerl (can be obtained from BioPerl website) +require Bio::Tk::BioTkPerl8_2; # requires version 0.82 of Gregg Helt's Bio::TkPerl (can be obtained from BioPerl website) # note that this is NOT the version available directly from Berkeley!! Tk::Widget->Construct('SeqCanvas'); @@ -170,7 +244,7 @@ Tk::Widget->Construct('SeqCanvas'); @ISA=qw(Bio::Tk::AnnotMap Bio::SeqI); -$Bio::Tk::SeqCanvas::VERSION='1.0'; +$Bio::Tk::SeqCanvas::VERSION='2.0'; { #Encapsulated class data @@ -192,7 +266,7 @@ $Bio::Tk::SeqCanvas::VERSION='1.0'; black => '#000000', brown => '#994444', dkgreen => '#00aa00', - ltgreen => '#ddffdd', + ltgreen => '#aaeeaa', ); my @colorlist = qw(darkblue magenta dkgreen fuschia orange purple chartreuse lightblue yellowgreen turquoise green yellow brown ltgreen); @@ -200,61 +274,72 @@ $Bio::Tk::SeqCanvas::VERSION='1.0'; #___________________________________________________________ #ATTRIBUTES my %_attr_data = # DEFAULT ACCESSIBILITY - ( xa => [0, 'read/write'], - ya => [0, 'read/write'], - xb => [0, 'read/write'], - yb => [0, 'read/write'], - -axis_loc => [0, 'read/write'], - -labelfont => ['TimesNewRoman 10 normal', 'read/write'], - -range => [undef, 'read/write'], - label => [undef, 'read/write'], # if this is defined then this is the Feature tag used to write labels on mapped objects - ScrollBar => [undef, 'read/write'], - ZoomBar => [undef, 'read/write'], - FinishedMap => [undef, 'read/write'], - DraftMap => [undef, 'read/write'], - MapSeq => [undef, 'read/write'], - MapFrame => [undef, 'read/write'], - ZoomFrame => [undef, 'read/write'], - ScrollFrame => [undef, 'read/write'], - DraftCanvas => [undef, 'read/write'], - FinishedCanvas => [undef, 'read/write'], - AnnotTextFrame => [undef, 'read/write'], # as below - AnnotTextCanvas => [undef, 'read/write'], # this is not used directly in SeqCanvas, but can be used by external routines to generate a third frame containing textual information beside the annotatinos (a la AceDB) - AnnotTextMap => [undef, 'read/write'], # as above - DraftLabelCanvas => [undef, 'read/write'], - FinishedLabelCanvas => [undef, 'read/write'], - #colors => [undef, 'read/write'], # the colors for each feature type; key = source, value = color from colors hash - #offsets => [undef, 'read/write'], # the offset for each feature type; key = source, value = offset from axis - FinishedSources => [undef, 'read/write'], # the list of genefinder sources to be mapped (one per row) - DraftSources => [undef, 'read/write'], # the list of genefinder sources to be mapped (one per row) - AdditionalSources => [["EST", "cDNA", "other"], 'read/write'], # TAIR has requested the ability to arbitrarily define additional source_tags which do not, at initialization, exist in the Bio::Seq object. - colordefs => [\%colordef, 'read'], - colorlist => [\@colorlist, 'read'], - zoom_triggers =>[{}, 'read/write'], - min_zoom =>[1, 'read/write'], - max_zoom =>[2, 'read/write'], - zoom_ratio =>[1, 'read/write'], - zoom_level =>[0, 'read/write'], - current_loc =>[1, 'read/write'], - finished_total_offset =>[undef, 'read/write'], #the largest offset for the finished map - draft_total_offset =>[undef, 'read/write'], # the largest offset for the draft map - actual_total_offset=>[undef, 'read/write'], # the larger of the two above (becomes the width of both maps) - -orientation => ['horizontal', 'read/write'], - FeatureID => [0, 'read/write'], # this is a simple incremental counter to assign each on-map object its index within the list of $feature objects in $self->IndexedFeatureList - whitespace => [20, 'read'], # whitespace is the distance between the axis and the first widget; the default never changes - IndexedFeatureList => [[], 'read/write'], # to compensate for Tk:;Canvas not being able to have a $reference as a tag element we put all $features into a list, and have the list index as a widget tag to associate widgets and their corresponding feature objects - SysMess => [undef, 'read/write'], # this is an (optional) handle back out to a label on the top level window to send system messages - dragx1 => [undef, 'read/write'], - dragy1 => [undef, 'read/write'], - dragx2 => [undef, 'read/write'], - dragy2 => [undef, 'read/write'], - ); - - my $_nextid=0; - my $_nextoffset = 2; - my %offsets; - my %colors; + ( + dxa => [0, 'read/write'], # x/y coords of the draft (d) and finished (f) canvases + dya => [0, 'read/write'], + dxb => [0, 'read/write'], + dyb => [0, 'read/write'], + fxa => [0, 'read/write'], + fya => [0, 'read/write'], + fxb => [0, 'read/write'], + fyb => [0, 'read/write'], + -axis_loc => [0, 'read/write'], + -labelfont => ['TimesNewRoman 9 normal', 'read/write'], + -range => [undef, 'read/write'], + label => [undef, 'read/write'], # if this is defined then this is the Feature tag used to write labels on mapped objects + ScrollBar => [undef, 'read/write'], + ZoomBar => [undef, 'read/write'], + FinishedMap => [undef, 'read/write'], + DraftMap => [undef, 'read/write'], + MapSeq => [undef, 'read/write'], + MapFrame => [undef, 'read/write'], + SeqFrame => [undef, 'read/write'], # the frame to hold the sequence display + SeqText => [undef, 'read/write'], # the sequence display text box + ZoomFrame => [undef, 'read/write'], + ScrollFrame => [undef, 'read/write'], + DraftCanvas => [undef, 'read/write'], + FinishedCanvas => [undef, 'read/write'], + AnnotTextFrame => [undef, 'read/write'], # as below + AnnotTextCanvas => [undef, 'read/write'], # this is not used directly in SeqCanvas, but can be used by external routines to generate a third frame containing textual information beside the annotatinos (a la AceDB) + AnnotTextMap => [undef, 'read/write'], # as above + DraftLabelCanvas => [undef, 'read/write'], + FinishedLabelCanvas => [undef, 'read/write'], + InitialFinishedLabels=> [['gene'], 'read/write'], + InitialSources => [['hand_annotation'], 'read/write'], + Colors => [{}, 'read/write'], # the colors associated with each source $Colors{$source} = "color"; Class property + colordefs => [\%colordef, 'read/write'], + colorlist => [\@colorlist, 'read/write'], + current_offsets => [{}, 'read/write'], + zoom_triggers => [{}, 'read/write'], + min_zoom => [1, 'read/write'], + max_zoom => [2, 'read/write'], + zoom_ratio => [1, 'read/write'], + zoom_level => [0, 'read/write'], + current_loc => [1, 'read/write'], + finished_total_offset=> [undef, 'read/write'], # the largest offset for the finished map + draft_total_offset => [undef, 'read/write'], # the largest offset for the draft map + width => [200, 'read/write'], # the "width" (perpendicular to the axis) of the maps at the outset + -orientation => ['horizontal', 'read/write'], + # FeatureID => [0, 'read/write'], # this is a simple incremental counter to assign each on-map object its index within the list of $feature objects in $self->IndexedFeatureList + whitespace => [10, 'read'], # whitespace is the distance between the axis and the first widget; the default never changes + IndexedFeatureList => [[], 'read/write'], # to compensate for Tk:;Canvas not being able to have a $reference as a tag element we put all $features into a list, and have the list index as a widget tag to associate widgets and their corresponding feature objects. This list is a class property, thus a feature will have a unique indexes across all created canvases. + SysMess => [undef, 'read/write'], # this is an (optional) handle back out to a label on the top level window to send system messages + dragx1 => [undef, 'read/write'], + dragy1 => [undef, 'read/write'], + dragx2 => [undef, 'read/write'], + dragy2 => [undef, 'read/write'], + def_offset => [10, 'read/write'], + + ); + + my $_nextid; + my $_nextDoffset; + my $_nextFoffset; + #my %offsets; # note that these are encapsulated CLASS properties + my %colors; # and thus are constant from one instantiation to the next my $_color_pos = 0; + my @FinishedSourceLabels; + my @Sources; #_____________________________________________________________ #METHODS, to operate on encapsulated class data @@ -275,9 +360,48 @@ $Bio::Tk::SeqCanvas::VERSION='1.0'; keys %_attr_data; } + sub FinishedSources { # for backwards compatibility + return \@FinishedSourceLabels; + } + + sub DraftSources { # for backwards compatibility + return \@Sources; + } + + sub FinishedSourceLabels { + my ($self, @labels) = @_; + if (scalar @labels){@FinishedSourceLabels = @labels} + return @FinishedSourceLabels; + } + + sub addFinishedSourceLabel { + my ($self, @labels) = @_; + my %sourcehash; + foreach my $source(@FinishedSourceLabels){$sourcehash{$source} = 1} + foreach my $new(@labels){$sourcehash{$new} = 1} + @FinishedSourceLabels = (keys %sourcehash); + return @FinishedSourceLabels; + } + + sub Sources { + my ($self, @sources) = @_; + if (scalar @sources){@Sources = @sources} + return @Sources; + } + + sub addSource { + my ($self, @new_sources) = @_; + my %sourcehash; + foreach my $source(@Sources){$sourcehash{$source} = 1} + foreach my $new(@new_sources){$sourcehash{$new} = 1} + @Sources = (keys %sourcehash); + return @Sources; + } + sub colorlist { return @colorlist } + sub colordef { return %colordef } @@ -288,7 +412,6 @@ $Bio::Tk::SeqCanvas::VERSION='1.0'; foreach my $key ($self->_standard_keys) { if ($key =~ /^-/) { - #print $key . "\n"; $_map_args{$key} = $self->{$key}; } } @@ -298,15 +421,28 @@ $Bio::Tk::SeqCanvas::VERSION='1.0'; sub next_id { return $_nextid++; } - sub next_offset { - return $_nextoffset++; # in this case increment it + + sub next_draft_offset { + if (!$_nextDoffset){$_nextDoffset=2} + return $_nextDoffset++; # in this case increment it } - sub offset_pointer { - return $_nextoffset; # in this case just send it as it is + + sub next_finished_offset { + if (!$_nextFoffset){$_nextFoffset=2} + return $_nextFoffset++; # in this case increment it } - sub current_offsets { - return \%offsets; + + sub draft_offset_pointer { + if (!$_nextDoffset){$_nextDoffset = 2} + return $_nextDoffset; # in this case just send it as it is + } + sub finished_offset_pointer { + if (!$_nextFoffset){$_nextFoffset = 2} + return $_nextFoffset; # in this case just send it as it is } + #sub current_offsets { + # return \%offsets; + #} sub current_colors { return \%colors; } @@ -366,9 +502,7 @@ sub AUTOLOAD { # Object Methods #__________________________________________________________________________________ -=pod - -=head2 METHODS +=head1 METHODS =head2 new @@ -378,10 +512,8 @@ sub AUTOLOAD { $Frame, [$lblSysMess | undef], $SeqObj, - -orientation => ['horizontal'|'vertical'], - label => $tag, - AdditionalSources => ["source1", "source2", "source3"], - ) + -orientation => ['horizontal'|'vertical'] + [, label => $tag]) Function : create a map from the Feature object provided Returns : Handle to the Map object @@ -391,10 +523,8 @@ sub AUTOLOAD { a Tk::Label or undef, a BioSeqI compliant object, the orientation for the map, - optionally the SeqFeature tag you wish to - use as the label - optionally, a list of source-tags that you require - but do not yet exist in the Sequence object + optionally the SeqFeature tag you wish to + use as the label =cut @@ -436,7 +566,6 @@ sub new { } } - if ($args{-orientation}) { if ($args{-orientation} =~ /h/i) {$self->{-orientation} = "horizontal"} elsif ($args{-orientation} =~ /v/i) {$self->{-orientation} = "vertical"} @@ -448,8 +577,10 @@ sub new { # the sub-frame to hold the zoom-bar $self->ZoomFrame($frame->Frame->pack(-side => 'bottom', -fill => 'x')); if ($self->{-orientation} eq "horizontal"){ + $self->SeqFrame($frame->Frame->pack(-side => 'top', expand => 1, -fill => 'x')); # the frame to hold the sequence text $self->ScrollFrame($frame->Frame->pack(-side => 'bottom', -fill => 'x')); } else { + $self->SeqFrame($frame->Frame->pack(-side => 'left', expand => 1, -fill => 'y')); # the frame to hold the sequence text $self->ScrollFrame($frame->Frame->pack(-side => 'right', -fill => 'y')); } $self->MapFrame($frame->Frame->pack(-side => 'top')); # the sub-frame to hold the two maps @@ -462,14 +593,9 @@ sub new { # - This line ensures that the sequences fills the allocated space. $self->{-range} = [0, ($SeqObj->length)]; - # - This line sets the "width" (relative to H/V orientation) of the map - # and is dependant on the number of different feature types - - _prepareSeqFeatures($self); + if (!($self->width)){$self->width(300)} - - - # within this routine the features are counted and assigned + # within these routines the features are counted and assigned # colors and offsets from the map axis. the width of each is # thus double (plus strand and minus strand) the largest axis # offset of a feature the largest offset value is stored in @@ -477,7 +603,6 @@ sub new { # ************************************************************ # *********************************************************** - #print $SeqObj->length; # Create the MapCanvases with correct dimensions # to make things clearer in the next routine here we figure @@ -486,61 +611,94 @@ sub new { # of a map depends on how many rows of different features are # displayed - i.e. its total offset - my $map_width = ($self->draft_total_offset > - $self->finished_total_offset) ? $self->draft_total_offset : - $self->finished_total_offset; - - $self->actual_total_offset($map_width); # set this for use in the _boxSelectedExon routine + my $map_width = ($self->width); #/ if ($self->{-orientation} eq "horizontal") { - my $DLF = $self->MapFrame->Frame->pack(-side => 'top'); # frame for Draft map and labels - my $FLF = $self->MapFrame->Frame->pack(-side => 'top'); # frame for Finished map and labels - $self->DraftLabelCanvas($DLF->Canvas(-width => 100, -height => $map_width, -background => "#ffffff")->pack(-side => 'left', -fill => 'both')); - $self->FinishedLabelCanvas($FLF->Canvas(-width => 100, -height => $map_width, -background => "#eeeeff")->pack(-side => 'left', -fill => 'both')); - $self->DraftCanvas($DLF->Canvas(-width => $window_length, -height => $map_width, -background => "#ffffff")->pack(-side => 'left', -fill => 'both')); - $self->FinishedCanvas($FLF->Canvas(-width => $window_length, -height => $map_width, -background => "#eeeeff")->pack(-side => 'left', -fill => 'both')); - - -# it would be nice to have the option to clear all selections by -# clicking elsewhere on the canvas, but because of the binding order -# (and the fact that the canvas itself responds to a click event on a -# widget) # the act of selecting a widget would cause this event to -# also be triggered... - - #$self->FinishedCanvas->Tk::bind("", sub {clearSelections($self)}); - #$self->DraftCanvas->Tk::bind("", sub {clearSelections($self)}); - - $self->yb($map_width); # each map is half of the height of a horizontal - $self->{-axis_loc} = (($self->yb)/2); #/ # axis goes half-way through the map on the Y axis - $self->xb($window_length); # height is unchanged - - my $s = $self->ScrollFrame->Scrollbar('-orient' => 'horizontal', '-command' => sub {$self->FinishedCanvas->xview(@_); $self->DraftCanvas->xview(@_)}); - $self->DraftCanvas->configure('-xscrollcommand' => ['set' => $s] ); # since they are identical only one canvas needs to feed-back to the scroll bar to show it's extents - $s->pack('-side'=>'bottom', '-fill'=>'x', '-expand' => 'x'); - $self->ScrollBar($s); + $self->SeqText($self->SeqFrame->Scrolled("Text", -scrollbars => "s", -height => 3, -background => 'black', -foreground => "white", -wrap => 'none')->pack(-expand => 1, -fill => 'both')); # text box for teh sequence + $self->SeqText->insert('end', "\n"); + $self->SeqText->insert('end', $SeqObj->seq); + + $self->dya(-$map_width/2); # each map is equally distributed + $self->fya(-$map_width/2); # each map is equally distributed + $self->dyb($map_width/2); # around the zero axis + $self->fyb($map_width/2); # around the zero axis + $self->{-axis_loc} = $map_width/2; # axis goes half-way (this is a strange bug in AnnotMap... even if you specify that the map is -100 to +100, you can't set the axis at 0, you have to set it at +100 to put it in the middle of this 200 range.... + $self->dxb($window_length); # height is unchanged + $self->fxb($window_length); # height is unchanged + + my $DLF = $self->MapFrame->Frame->pack(-side => 'top', -fill => 'both'); # frame for Draft map and labels + my $FLF = $self->MapFrame->Frame->pack(-side => 'top', -fill => 'both'); # frame for Finished map and labels + + $self->DraftLabelCanvas($DLF->Canvas(-width => 100, -height => $map_width, -background => "#ffffff")->pack(-side => 'left', -fill => 'both')); + $self->DraftCanvas($DLF->Canvas(-width => $window_length, -height => $map_width, -background => "#ffffff")->pack(-side => 'left', -fill => 'both')); + my $Dyscrollbar = $DLF->Scrollbar('-orient' => 'vertical','-command' => sub {$self->DraftLabelCanvas->yview(@_);$self->DraftCanvas->yview(@_)})->pack(-side => 'left', '-fill'=>'y', '-expand' => 'y'); + + $self->FinishedLabelCanvas($FLF->Canvas(-width => 100, -height => $map_width, -background => "#eeeeff")->pack(-side => 'left', -fill => 'both')); + $self->FinishedCanvas($FLF->Canvas(-width => $window_length, -height => $map_width, -background => "#eeeeff")->pack(-side => 'left', -fill => 'both')); + my $Fyscrollbar = $FLF->Scrollbar('-orient' => 'vertical','-command' => sub {$self->FinishedLabelCanvas->yview(@_);$self->FinishedCanvas->yview(@_)})->pack(-side => 'left', '-fill'=>'y', '-expand' => 'y'); + + $self->DraftLabelCanvas->configure('-yscrollcommand' => ['set' => $Dyscrollbar] ); + $self->FinishedLabelCanvas->configure('-yscrollcommand' => ['set' => $Fyscrollbar] ); + + $self->DraftCanvas->configure('-yscrollcommand' => ['set' => $Dyscrollbar] ); + $self->FinishedCanvas->configure('-yscrollcommand' => ['set' => $Fyscrollbar] ); + + $self->DraftCanvas->configure(-scrollregion => [1, $self->dya, $self->dxb, $self->dyb]); + $self->FinishedCanvas->configure(-scrollregion => [1, $self->fya, $self->fxb, $self->fyb]); + $self->DraftLabelCanvas->configure(-scrollregion => [1, $self->dya, 100, $self->dyb]); + $self->FinishedLabelCanvas->configure(-scrollregion => [1, $self->fya, 100, $self->fyb]); + + my $s = $self->ScrollFrame->Scrollbar('-orient' => 'horizontal', '-command' => sub {$self->FinishedCanvas->xview(@_); $self->DraftCanvas->xview(@_)}); + $self->DraftCanvas->configure('-xscrollcommand' => ['set' => $s] ); # since they are identical only one canvas needs to feed-back to the scroll bar to show it's extents + $s->pack('-side'=>'bottom', '-fill'=>'x', '-expand' => 'x'); + $self->ScrollBar($s); + } else { # vertical - my $DLF = $self->MapFrame->Frame->pack(-side => 'left'); # frame for Draft map and labels - my $FLF = $self->MapFrame->Frame->pack(-side => 'left'); # frame for Finished map and labels - $self->DraftLabelCanvas($DLF->Canvas(-width => $map_width, -height => 100, -background => "#ffffff")->pack(-side => 'top', -fill => 'both')); - $self->FinishedLabelCanvas($FLF->Canvas(-width => $map_width, -height => 100, -background => "#eeeeff")->pack(-side => 'top', -fill => 'both')); - $self->DraftCanvas($DLF->Canvas(-width => $map_width, -height => $window_length, -background => "#ffffff")->pack(-side => 'top', -fill => 'both')); - $self->FinishedCanvas($FLF->Canvas(-width => $map_width, -height => $window_length, -background => "#eeeeff")->pack(-side => 'top', -fill => 'both')); - $self->xb($map_width); # each map is half of the width of a vertical - $self->{-axis_loc} = (($self->xb)/2); #/ # axis goes half-way through the map on the X axis - $self->yb($window_length); # height is unchanged - - my $s = $self->ScrollFrame->Scrollbar('-orient' => 'vertical', '-command' => sub {$self->FinishedCanvas->yview(@_); $self->DraftCanvas->yview(@_)}); - $self->DraftCanvas->configure('-yscrollcommand' => ['set' => $s] ); - $s->pack('-side'=>'right', '-fill'=>'y', '-expand' => 'y'); - $self->ScrollBar($s); + + $self->dxa(-$map_width/2); # each map is equally distributed + $self->fxa(-$map_width/2); # each map is equally distributed + $self->dxb($map_width/2); # around the zero axis + $self->fxb($map_width/2); # around the zero axis + $self->{-axis_loc} = $map_width/2; # axis goes half-way (this is a strange bug in AnnotMap... even if you specify that the map is -100 to +100, you can't set the axis at 0, you have to set it at +100 to put it in the middle of this 200 range.... + $self->dyb($window_length); # height is unchanged + $self->fyb($window_length); # height is unchanged + + my $DLF = $self->MapFrame->Frame->pack(-side => 'left', -fill => 'both'); # frame for Draft map and labels + my $FLF = $self->MapFrame->Frame->pack(-side => 'left', -fill => 'both'); # frame for Finished map and labels + + $self->DraftLabelCanvas($DLF->Canvas(-width => $map_width, -height => 100, -background => "#ffffff")->pack(-side => 'top', -fill => 'both')); + $self->DraftCanvas($DLF->Canvas(-width => $map_width, -height => $window_length, -background => "#ffffff")->pack(-side => 'top', -fill => 'both')); + my $Dyscrollbar = $DLF->Scrollbar('-orient' => 'horizontal','-command' => sub {$self->DraftLabelCanvas->xview(@_);$self->DraftCanvas->xview(@_)})->pack(-side => 'top', '-fill'=>'x', '-expand' => 'y'); + + $self->FinishedLabelCanvas($FLF->Canvas(-width => $map_width, -height => 100, -background => "#eeeeff")->pack(-side => 'top', -fill => 'both')); + $self->FinishedCanvas($FLF->Canvas(-width => $map_width, -height => $window_length, -background => "#eeeeff")->pack(-side => 'top', -fill => 'both')); + my $Fyscrollbar = $FLF->Scrollbar('-orient' => 'horizontal','-command' => sub {$self->FinishedLabelCanvas->xview(@_);$self->FinishedCanvas->xview(@_)})->pack(-side => 'top', '-fill'=>'x', '-expand' => 'y'); + + $self->DraftLabelCanvas->configure('-xscrollcommand' => ['set' => $Dyscrollbar] ); + $self->FinishedLabelCanvas->configure('-xscrollcommand' => ['set' => $Fyscrollbar] ); + + $self->DraftCanvas->configure('-xscrollcommand' => ['set' => $Dyscrollbar] ); + $self->FinishedCanvas->configure('-xscrollcommand' => ['set' => $Fyscrollbar] ); + + $self->DraftCanvas->configure(-scrollregion => [$self->dxa, 1, $self->dxb, $self->dyb]); + $self->FinishedCanvas->configure(-scrollregion => [$self->fxa, 1, $self->fxb, $self->fyb]); + $self->DraftLabelCanvas->configure(-scrollregion => [$self->dxa, 1, $self->dxb, $self->dyb]); + $self->FinishedLabelCanvas->configure(-scrollregion => [$self->dxa, 1, $self->dxb, 100]); + + my $s = $self->ScrollFrame->Scrollbar('-orient' => 'vertical', '-command' => sub {$self->FinishedCanvas->yview(@_); $self->DraftCanvas->yview(@_)}); + $self->DraftCanvas->configure('-yscrollcommand' => ['set' => $s] ); + $s->pack('-side'=>'right', '-fill'=>'y', '-expand' => 'y'); + $self->ScrollBar($s); } + $self->DraftCanvas->update; + $self->DraftCanvas->Tk::bind('', sub { $self->DraftCanvas->Tk::focus; } ); # set focus on the appropriate map when mouse enters $self->FinishedCanvas->Tk::bind('', sub { $self->FinishedCanvas->Tk::focus; } ); # the space # and now create the maps - $self->FinishedMap($self->FinishedCanvas->AnnotMap($self->xa, $self->ya, $self->xb, $self->yb, $self->MapArgs)); - $self->DraftMap($self->DraftCanvas->AnnotMap($self->xa, $self->ya, $self->xb, $self->yb, $self->MapArgs)); + $self->FinishedMap($self->FinishedCanvas->AnnotMap($self->fxa, $self->fya, $self->fxb, $self->fyb, $self->MapArgs)); + $self->DraftMap($self->DraftCanvas->AnnotMap($self->dxa, $self->dya, $self->dxb, $self->dyb, $self->MapArgs)); _setupAxes($self); # draw the axis on the two maps @@ -568,19 +726,34 @@ sub new { $zoomscale->pack(-side => 'left', -expand => 'yes', -fill => 'x', -anchor => 'e'); $self->ZoomBar($zoomscale); + foreach my $source(@{$self->InitialSources}){ + $self->_check_and_expand_draft_canvas($source); + $self->addSource($source); + } + foreach my $label(@{$self->InitialFinishedLabels}){ + $self->_check_and_expand_finished_canvas($label); + $self->addFinishedSourceLabel($label); + } + foreach my $source($self->Sources){ + $self->_drawDraftLabels([$source]); + } + foreach my $label($self->FinishedSourceLabels){ + $self->_drawFinishedLabels([$label]); + } + # now that everything is setup, go ahead and draw the features - _drawTopLevelFeatures($self); - _drawSubFeatures($self); - _bindMultiSelection($self); + my @features = $self->MapSeq->top_SeqFeatures; + my @IDs = $self->mapFeatures("both", \@features); # only the features from a top_SeqFeatures call -> screened for GeneStructure objects in this routine + + $self->_bindMultiSelection(); my $toplevel = $self->DraftCanvas->toplevel; my $a = $toplevel->geometry; - #print "\n\n$a\n\n"; # w h x y $a =~ /(\d+)x(\d+)\+-?(\d+)\+-?(\d+)/; #get current screen position of top-level window eg. 500x300+20+-45 $toplevel->geometry("$1"."x"."$2+10+10"); # set it so that the control bar is entirely visible at the top of the screen - return $self; # return the handle - + #return ($self, \@IDs); # return the handle + return $self; } sub _bindMultiSelection { @@ -598,10 +771,12 @@ sub _bindMultiSelection { # the x1/y1 are stored during the button-press event above my ($x1, $y1) = ($self->dragx1, $self->dragy1); # convert the global x/y coordinate to the canvas x/y coords - my $x2 = $self->DraftCanvas->canvasx($tx2); + + my $x2 = $self->DraftCanvas->canvasx($tx2); my $y2 = $self->DraftCanvas->canvasy($ty2); # delete existing boxse - $self->DraftCanvas->delete("withtag", "multi_box"); + return if (!($x1 && $x2 && $y1 && $y2)); + $self->DraftCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->delete("withtag", "multi_box"); # " # create a new one $self->DraftCanvas->createRectangle($x1, $y1, $x2, $y2, @@ -618,6 +793,7 @@ sub _bindMultiSelection { my ($x1, $x2, $y1, $y2) = ($self->dragx1, $self->dragx2, $self->dragy1, $self->dragy2); + return if (!($x1 && $x2 && $y1 && $y2)); if ($x1 > $x2){($x1, $x2) = ($x2, $x1)} if ($y1 > $y2){($y1, $y2) = ($y2, $y1)} if (($x2-$x1 < 10 )||($y2 - $y1 < 10)) { # set sensitivity @@ -649,7 +825,8 @@ sub _bindMultiSelection { my ($x1, $y1) = ($self->dragx1, $self->dragy1); my $x2 = $self->FinishedCanvas->canvasx($tx2); my $y2 = $self->FinishedCanvas->canvasy($ty2); - $self->DraftCanvas->delete("withtag", "multi_box"); + return if (!($x1 && $x2 && $y1 && $y2)); + $self->DraftCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->createRectangle($x1, $y1,$x2, $y2, -tags => "multi_box"); @@ -664,7 +841,8 @@ sub _bindMultiSelection { my ($x1, $x2, $y1, $y2) = ($self->dragx1, $self->dragx2, $self->dragy1, $self->dragy2); - if ($x1 > $x2){($x1, $x2) = ($x2, $x1)} + return if (!($x1 && $x2 && $y1 && $y2)); + if ($x1 > $x2){($x1, $x2) = ($x2, $x1)} if ($y1 > $y2){($y1, $y2) = ($y2, $y1)} if (($x2-$x1 < 10 )||($y2 - $y1 < 10)) { # set sensitivity # delete existing boxes @@ -684,6 +862,8 @@ sub _bindMultiSelection { Ev('x'), Ev('y')] ); } + + sub _setupAxes { my ($self)=@_; my $draftmap = $self->DraftMap; # set references to keep code clearer @@ -890,187 +1070,270 @@ sub DoZoom { } } -sub _prepareSeqFeatures { - my ($self) = @_; - # ******** TOP LEVEL FEATURES ***************** - my $TOP = $self->SysMess; - if ($TOP){$TOP->configure(-text => "preparing Seq Features"); $TOP->update} - - my @features = $self->MapSeq->top_SeqFeatures; # first the top level features - my @Finishedsources; - if ($TOP){$TOP->configure(-text => "Extracting Source tags"); $TOP->update} - - # this extracts the "source" tag from each feature, - push @Finishedsources, ("gene", @{$self->AdditionalSources}, _extract_sources(@features)); - - # Because of the way BioPerl parses genbank we filter out the - # "gene" features in the _extract_sources routine because even - # exons are called "genes" so the whole terminology becomes - # meaningless... that's why we add this feature-type back in here - # as an exclusively top-level feature - - # make variable to temporarily hold the sources for each subfeature - my @tempsources; - foreach my $feature(@features){ - # now take the sub-features from each top-level feature - my @subfeatures = $feature->sub_SeqFeature; - # extract the source names from all subfeatures - my @tempsources = _extract_sources(@subfeatures); - my $flag; - foreach my $tempsource(@tempsources){ # check each one in turn - $flag = 0; - # to see if it exists in the list of Finished sources we already know - foreach my $source(@Finishedsources){ - if ($tempsource eq $source) {$flag = 1} - } - if ($flag == 0) {push @Finishedsources, $tempsource} # and if not, then add it. +sub _processSeqFeatures { + # all features should be top_SeqFeatures when they enter this routine... + my ($self, $features) = @_; + my @features = @{$features}; + foreach my $feature(@features){ + $self->_extract_sources([$feature]); # this gets the feature and all sub-features, updates labels and canvas sizes + } + foreach my $feature(@features){ + $self->_extract_transcripts([$feature]); # this updates both labels and canvas sizes } - } - if ($TOP){$TOP->configure(-text => "Assigning Colors to top-level Sources"); $TOP->update} - _assign_colors($self, @Finishedsources); # assign a unique color to each source - if ($TOP){$TOP->configure(-text => "Assigning Offsets to top-level Sources"); $TOP->update} - $self->{finished_total_offset} = _assign_offsets($self, @Finishedsources); # assign a unique axis-offset to each source - $self->FinishedSources(\@Finishedsources); # stick the list into the $self object to make it easy to get to - - - # ********** SUB FEATURES ****************** - # this call returns all features, including top-level "gene" features - @features = $self->MapSeq->all_SeqFeatures; - my @Draftsources; - # we need an additional class "hand-annotation" to deal with modified exons - push @Draftsources, (@{$self->AdditionalSources}, _extract_sources(@features), "hand_annotation",); - # so we don't bugger-up primary data - # at the request of TAIR we have added the AdditionalSources, which provides a space for adding features with source-tags that - # were not present in the initializing Sequence object. good idea guys! - - if ($TOP){$TOP->configure(-text => "Assigning Colors to sub-level Sources"); $TOP->update} - _assign_colors($self, @Draftsources); # assign colors to each - if ($TOP){$TOP->configure(-text => "Assigning Offsets to sub-level Sources"); $TOP->update} - $self->{draft_total_offset} = _assign_offsets($self, @Draftsources); # assign offsets to each - # stick it into $self to make it easier to get to from other places - $self->DraftSources(\@Draftsources); } -sub _drawTopLevelFeatures { - my ($self) = @_; - my $TOP = $self->SysMess; - if ($TOP){$TOP->configure(-text => "Drawing Top-Level features"); $TOP->update} - - my (@genes, @subfeatures, @FinishedFeatures); - my @features = $self->MapSeq->top_SeqFeatures; # extract top level features from bioPerl Seq object - foreach my $feature(@features){ - next if (!($feature->primary_tag eq "gene")); # if it aint a gene, don't map it - push @genes, $feature; # if it is, then stick it in a list and... +sub _check_and_expand_draft_canvas { - my @subFeatureList=_recurse_subFeatures($feature); # get a list of all of its sub-features - push @subfeatures, @subFeatureList; # stick them into a list too - } - - push @FinishedFeatures, @genes; - push @FinishedFeatures, @subfeatures; # stick the lists together and... - mapFeatures($self, # MAP THEM! - 'finished', # which canvas to draw on - \@FinishedFeatures, # the list of top-level genes and sub-features - ); - _drawLabels($self, - $self->FinishedLabelCanvas, # the canvas upon which to draw the labels - $self->FinishedSources, # the source names that will be the text of each label - ); + my ($self,$source) = @_; + + foreach my $current_source($self->Sources){ + return if ($current_source eq $source); # if the given source exists, then exit this routine ASAP + } + # at this point we have determined that the $source is a new one. + + my $offset = $self->next_draft_offset; + my $ColorPos = $self->next_colorpos; + my @colorlist = $self->colorlist; + my %colordef = $self->colordef; + + $self->current_colors->{$source} = $colordef{$colorlist[$ColorPos]}; + $self->current_offsets->{$source} = $self->whitespace + ($offset * $self->def_offset); + if ($self->{-orientation} eq "horizontal"){ + my $yb = $self->current_offsets->{$source}; + my $ya = -$yb; + if ($yb > $self->dyb){ + $self->dya($ya); + $self->dyb($yb); + } + $self->_drawDraftLabels([$source]); + $self->DraftCanvas->update; + } else { + my $xb = $self->current_offsets->{$source}; + my $xa = -$xb; + if ($xb > $self->dxb){ + $self->dxa($xa); + $self->dxb($xb); + } + $self->_drawDraftLabels([$source]); + $self->DraftCanvas->update; + } } -sub _drawSubFeatures { - my ($self) = @_; # as above, except take all features but throw away the genes - my $TOP = $self->SysMess; - if ($TOP){$TOP->configure(-text => "Drawing Sub features"); $TOP->update} - my @DraftFeatures; - my @features = $self->MapSeq->top_SeqFeatures; - foreach my $feature(@features){ - next if ($feature->primary_tag eq "gene"); - my @subFeatureList=_recurse_subFeatures($feature); - push @DraftFeatures, @subFeatureList; - push @DraftFeatures, $feature; - } - mapFeatures($self, - 'draft', - \@DraftFeatures, # the sub-features associated with that object - ); - - _drawLabels($self, - $self->DraftLabelCanvas, # as above - $self->DraftSources, - ); -} +sub _check_and_expand_finished_canvas { -sub _recurse_subFeatures { - my $feature=shift; - return unless $feature; - return (_recurse_subFeatures($feature->sub_SeqFeature), #recursively search through sub_SeqFeatures - $feature->sub_SeqFeature #add this level list of sub_SeqFeatures - ); + my ($self, $label) = @_; + + foreach my $current_label($self->FinishedSourceLabels){ + return if ($current_label eq $label); # if the given source exists, then exit this routine ASAP + } + # at this point we have determined that the $source is a new one. + + my $offset = $self->next_finished_offset; + + my @colorlist = $self->colorlist; + my %colordef = $self->colordef; + my $this_offset = $self->whitespace + ($offset * $self->def_offset); + + $self->current_colors->{$label} = $colordef{$colorlist[0]}; # was $colorpos instead of 0... but I want them to be consistent + $self->current_offsets->{$label} = $this_offset; + + if ($self->{-orientation} eq "horizontal"){ + my $yb = $this_offset; + my $ya = -$yb; + if ($yb > $self->fyb){ + $self->fya($ya); + $self->fyb($yb); # write the new dimensions of self to self + } + $self->_drawFinishedLabels([$label]); + $self->FinishedCanvas->update; + } else { + my $xb = $this_offset; + my $xa = -$xb; + if ($xb > $self->fxb){ + $self->fxa($xa); + $self->fxb($xb); # write the new dimensions of self to self + } + $self->_drawFinishedLabels([$label]); + $self->FinishedCanvas->update; + } + return $this_offset; } -sub _extract_sources { - my (@features) = @_; - my @sources; +sub _extract_sources { # sources are used to define both offset and color on the draft canvas, but only color on the finished canvas + my ($self, $features) = @_; + my @features = @{$features}; + my %sources; # use a hash do simplify screening for duplicate entries - assignment of 'undef' to the same hash key can be safely made multiple times + my @currentSources = $self->Sources; + foreach my $source(@currentSources){ + $sources{$source}=1; + } my $flag; - #@sources = undef; foreach my $feature(@features) { - $flag = 0; - my $this_source = $feature->source_tag; - if (!$this_source) {$this_source = "undefined"} - - next if ($feature->primary_tag eq "gene"); # this filters out top-level gene objects - # so that they are not included in the "get all" features list - foreach my $source(@sources){ - if ($this_source eq $source) {$flag = 1} - } - if ($flag == 0) {push @sources, $this_source} + if (!(($feature->primary_tag eq "gene")||($feature->can("transcripts")))){ # this filters out top-level gene objects + my $this_source = $feature->source_tag; # get the source tag + if (!$this_source) {$this_source = "undefined"} # or assign it if it doesn't exist + if (!$sources{$this_source}){$self->_check_and_expand_draft_canvas($this_source);} # if it is unknown, then expand the canvas + $sources{$this_source}=1; # this is essentially a non-redundant list of sources # now set it to "known" + } + my @subfeatures = $self->_getAllSubFeatures($feature); # get all sub-features + foreach my $subfeature(@subfeatures){ + next if (($subfeature->primary_tag eq "gene")||($subfeature->can("transcripts"))||($subfeature->can("exons"))); # this filters out top-level gene objects and transcript objects + my $this_source = $subfeature->source_tag; # do the same as above + if (!$this_source) {$this_source = "undefined"} + if (!$sources{$this_source}){$self->_check_and_expand_draft_canvas($this_source);} + $sources{$this_source}=1; + } } + my @sources = (keys %sources); # get the non-redundant list + $self->Sources(@sources); # and make the list of sources return @sources; } -sub _assign_colors { - #print "assigning Colors\n"; - my ($self, @sources) = @_; - my $ColorPos; - my @colorlist = $self->colorlist; - my %colordef = $self->colordef; - foreach my $source(@sources) { - if (! $self->current_colors->{$source} ){ - $ColorPos = $self->next_colorpos; - $self->current_colors->{$source} = $colordef{$colorlist[$ColorPos]}; +sub _getAllSubFeatures { + my ($self, $feature) = @_; + my @all_features; + push @all_features, $feature; + if ($feature->sub_SeqFeature){ + foreach my $sub($feature->sub_SeqFeature){ + push @all_features, $self->_getAllSubFeatures($sub); + } } + return @all_features; +} + + +sub _extract_transcripts { + my ($self, $features) = @_; + my @features = @{$features}; + my %Labels; + my @currentLabels = $self->FinishedSourceLabels; # at the beginning this should be a list of 1 element - "gene" + foreach my $label(@currentLabels){ + $Labels{$label}=1; # set these labels as being "known" to us. } + + foreach my $feature(@features) { + my $model=0; # this is a counter for the number of transcript models contained in the gene + + next if (!($feature->can("transcripts")) && !($feature->can("exons")) && ($feature->primary_tag ne "gene")); # we only want GeneStructureI compliant objects on finished map, but allow things with primary tag "gene" to be mapped also just to be compliant with SeqIO parsing of genbank files (ugly!!) + $feature->{SeqCanvas_offset} = $self->current_offsets->{"gene"}; # assign a gene offset to this feature + if ($feature->can("transcripts")){ # and get out now if it isn't GeneStructureI compliant + my @transcripts = $feature->transcripts; # get all transcripts from this object + next if ($#transcripts == -1); # exit if there are none + foreach my $transcript(@transcripts){ # for every transcript give it a new offset & assign it directly to the transcript object + ++$model; + my $offset; # increment model counter -> increment offset from the axis. + if (!($Labels{"transcript$model"})){$offset = $self->_check_and_expand_finished_canvas("transcript$model")} # if label is unknown add it to the finished label canvas, update both label canvas and map size + else {$offset = $self->current_offsets->{"transcript$model"}} + $transcript->{SeqCanvas_offset} = $offset; + $Labels{"transcript$model"} = 1; # define this label as known + } + } elsif ($feature->can("exons")){ + + } else {next} + } + my @transcripts = (keys %Labels); + $self->FinishedSourceLabels(@transcripts); + return @transcripts; + } -sub _assign_offsets { # this also draws the labels on the rows - #print "assigning Offsets\n"; - my ($self, @sources) = @_; - my $def_offset = 10; #the space between rows of features - my $whitespace = $self->whitespace; # a bit of space between the axis and the first feature - my $increment; +sub _drawFinishedLabels { + + my ($self, $sources) = @_; + my $canvas = $self->FinishedLabelCanvas; + my $map = $self->FinishedCanvas; + ########################################################################### + # now draw the labels on the label canvas - one for each line of features + ############################################################################# + + my $text_width = ($self->{-orientation} eq "horizontal") ? 0:1; + # for horizontal it is 20 characters long, for vertical it is 1 character + # wide (essentially vertically written) + # now draw the labels + my @sources = @{$sources}; foreach my $source(@sources) { - if ($source eq "gene"){ $self->current_offsets->{$source} = $whitespace; next} # we want these to be right near the axis + my $color = $self->current_colors->{$source}; + my $offset = $self->current_offsets->{$source}; + if ($self->{-orientation} eq "vertical") { + # vertical text requires splitting between every character, + # and splits, on a canvas, can only occur where there is a space + $source = join ' ', (split //, $source); + # so we break the string up with spaces between each character. + } - if (!($self->current_offsets->{$source})){ # if there is no defined offset for this source - $increment = $self->next_offset; # get the next increment value for offsets - $self->current_offsets->{$source} = $whitespace + ($increment * $def_offset); # assign the offset as increment*distance - #print "$source with offset " . $self->current_offsets->{$source} . "\n"; - } + if ($self->{-orientation} eq "horizontal") { + $canvas->createText(5, $offset-5, + # the -5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -font => "Courier 10 normal", + -anchor => 'nw', + ); + $canvas->createText(5, -$offset-5, + # the -5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -font => "Courier 10 normal", + -anchor => 'nw', + + ); + } else { + $canvas->createText($offset-5, 5, + # the +5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -anchor => 'nw', + ); + $canvas->createText(-$offset-5, 5, + # the +5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -anchor => 'nw', + ); + + } } - return (($whitespace + (($self->offset_pointer) * $def_offset))*2); # double the (offset + whitespace) = total map width + if ($self->{-orientation} eq "horizontal"){ + $canvas->configure(-scrollregion => [1, $self->fya-10, 100, $self->fyb+10]); + $map->configure(-scrollregion => [1, $self->fya-10, $self->fxa, $self->fyb+10]); + $self->FinishedMap->{canvas_min} = $self->fya-10; # inform AnnotMap about the new size for zooming purposes + $self->FinishedMap->{canvas_max} = $self->fyb+10; # the +/- 10 is because I set the canvas scroll region for the labels to be +/- 10 compared to the actual offset + } else { + $canvas->configure(-scrollregion => [$self->fxa-10, 1, $self->fxb+10, 100]); + $map->configure(-scrollregion => [$self->fxa-10, 1, $self->fxb+10, $self->fyb]); + $self->FinishedMap->{canvas_min} = $self->fxa-10; # inform AnnotMap about the new size for zooming purposes + $self->FinishedMap->{canvas_max} = $self->fxb+10; + } } -sub _drawLabels { - my ($self, $labels, $sources) = @_; +sub _drawDraftLabels { + my ($self, $sources) = @_; + my $canvas = $self->DraftLabelCanvas; + my $map = $self->DraftCanvas; ########################################################################### # now draw the labels on the label canvas - one for each line of features ############################################################################# @@ -1079,73 +1342,76 @@ sub _drawLabels { # wide (essentially vertically written) # now draw the labels my @sources = @{$sources}; - foreach my $source(@sources) { - my $color = $self->current_colors->{$source}; - my $offset = $self->current_offsets->{$source}; - if ($self->{-orientation} eq "vertical") { - # vertical text requires splitting between every character, - # and splits only occurr before spaces - $source = join ' ', (split //, $source); - # so we break the string up with spaces between each character. - } - if ($self->{-orientation} eq "horizontal") { - $labels->createText(5, ($self->{-axis_loc}+$offset)-5, - # the -5 is because the AnnotMap function draws - # the bars using a different centering mechanism - # relative to simply writing text on the canvas - -text => $source, - -fill => $color, - -width => $text_width, - #-justify => 'right', - -font => "Courier 10 normal", - -anchor => 'nw', - ); - $labels->createText(5, ($self->{-axis_loc}-$offset)-5, - # the -5 is because the AnnotMap function draws - # the bars using a different centering mechanism - # relative to simply writing text on the canvas - -text => $source, - -fill => $color, - -width => $text_width, - #-justify => 'right', - -font => "Courier 10 normal", - -anchor => 'nw', - - ); - } else { - $labels->createText(($self->{-axis_loc}+$offset)-5, 5, - # the +5 is because the AnnotMap function draws - # the bars using a different centering mechanism - # relative to simply writing text on the canvas - -text => $source, - -fill => $color, - -width => $text_width, - #-justify => 'right', - -anchor => 'nw', - ); - $labels->createText(($self->{-axis_loc}-$offset)-5, 5, - # the +5 is because the AnnotMap function draws - # the bars using a different centering mechanism - # relative to simply writing text on the canvas - -text => $source, - -fill => $color, - -width => $text_width, - #-justify => 'right', - -anchor => 'nw', - ); + foreach my $source(@sources) { + my $color = $self->current_colors->{$source}; + my $offset = $self->current_offsets->{$source}; + if ($self->{-orientation} eq "vertical") { + # vertical text requires splitting between every character, + # and splits only occurr before spaces + $source = join ' ', (split //, $source); + # so we break the string up with spaces between each character. + } - } + if ($self->{-orientation} eq "horizontal") { + $canvas->createText(5, $offset-5, + # the -5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -font => "Courier 10 normal", + -anchor => 'nw', + ); + $canvas->createText(5, -$offset-5, + # the -5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -font => "Courier 10 normal", + -anchor => 'nw', + + ); + } else { + $canvas->createText($offset-5, 5, + # the +5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -anchor => 'nw', + ); + $canvas->createText(-$offset-5, 5, + # the +5 is because the AnnotMap function draws + # the bars using a different centering mechanism + # relative to simply writing text on the canvas + -text => $source, + -fill => $color, + -width => $text_width, + #-justify => 'right', + -anchor => 'nw', + ); + + } } -} - -sub _doubleClickFeature { - -# this routine simply adds a "double_clicked" tag to whatever widget -# was double-clicked. more importantly, it **erases the -# "double_clicked" tag from any previously double-clicked widget on -# either canvas - + if ($self->{-orientation} eq "horizontal"){ + $canvas->configure(-scrollregion => [1, $self->dya-10, 100, $self->dyb+10]); + $map->configure(-scrollregion => [1, $self->dya-10, $self->dxa, $self->dyb+10]); + $self->DraftMap->{canvas_min} = $self->dya-10; # inform AnnotMap about the new size for zooming purposes + $self->DraftMap->{canvas_max} = $self->dyb+10; + } else { + $canvas->configure(-scrollregion => [$self->dxa-10, 1, $self->dxb+10, 100]); + $map->configure(-scrollregion => [$self->dxa-10, 1, $self->dxb+10, $self->dyb]); + $self->DraftMap->{canvas_min} = $self->dxa-10; # inform AnnotMap about the new size for zooming purposes + $self->DraftMap->{canvas_max} = $self->dxb+10; # the +/- 10 is because I set the canvas scroll region for the labels to be +/- 10 compared to the actual offset + } } sub _selectFeature { @@ -1177,9 +1443,8 @@ sub _selectFeature { push @tags, ($canvas->gettags('now_current')); # one or the other of these will return undef under normal circumstances - my ($FeatureID, $strand, $source) = _extractTags(\@tags); + my ($FeatureID, $strand, $source, $start, $stop, $offset) = _extractTags(\@tags); # parse the tags to get the juicy bits - my $exitflag = "false"; foreach my $tag (@tags){ if ($tag eq "selected"){ # this object has already been selected! so... unselect it @@ -1194,21 +1459,28 @@ sub _selectFeature { my ($FeatureIndex) = ($FeatureID =~ /^FID(.+)/); # get the IndexedFeatureList index pointer for this feature - if ( ! defined $FeatureIndex ) { - $canvas->dtag('now_current'); + if ( ! defined $FeatureIndex ) { # there are all sorts of other invisible junks on the map, + $canvas->dtag('now_current'); # so filter out these things and ignore them if they are clicked on return; } - # there are all sorts of other invisible junks on the map for some reason, - # so filter out these things + + - my $feature = $self->{IndexedFeatureList}->[$FeatureIndex]; + #my $feature = $self->{IndexedFeatureList}->[$FeatureIndex]; # then extract this Bio::Feature object from the list - my $start = $feature->start; - # $feature now contains the actual BioSeqFeature object, + # $feature now contains the actual BioSeqFeature object, # so we can use the Feature methods... + # like start, stop, strand, etc. + #my $start = $feature->start; + #my $stop = $feature->end; + + #my $offset; + #if ($feature->has_tag("SeqCanvas_offset")){ + # ($offset) = $feature->each_tag_value("SeqCanvas_offset"); + #} else { + # $offset = $self->current_offsets->{$source}; + #} - my $stop = $feature->end; # like start, stop, strand, etc. - my $offset = $self->current_offsets->{$source}; # offset from axis always depends on the source tag # quickly nab the position that was clicked so that we can zoom around this my $current_loc = ($self->{-orientation} eq "horizontal") ? @@ -1224,14 +1496,30 @@ sub _selectFeature { $canvas->addtag("selected", "withtag", "$FeatureID"); #original - $canvas->dtag('now_current'); + $canvas->dtag('now_current'); + + my ($index1, $index2); + if ($self->{-orientation} eq "horizontal"){ # only horizontal maps display sequence info + $index1 = "2." . ($start-1); # convert seq coordinates into text-coordinates + $index2 = "2." . ($stop); + } + my $color = $self->current_colors->{$source}; + + if ($self->{-orientation} eq "horizontal"){ + if ($SorM eq "single"){$self->SeqText->tagDelete("currently_selected", "currently_selected")} # remove existing tags + $self->SeqText->tagAdd("currently_selected", $index1, $index2); # add the tag to the new region + $self->SeqText->tagConfigure("currently_selected", -foreground => $color); # recolor it to the correct color + $self->SeqText->see($index1); # bring it into view + } + } sub _drawSelectionBox { # this is conceptually based on Nomi Harris' Genotator code my($self, $canvas, $map, $start, $stop, $offset, $FeatureID, $SorM) = @_; - #print "start $start end $end offset $offset total offset $total_offset exon $ExonID SM $SorM\n"; + #print "start $start end $stop offset $offset SM $SorM\n"; - my $y1 = (($self->actual_total_offset)/2) + $offset -3; #/ + # ******* THIS MUST BE CHANGED ******** + my $y1 = $offset -3; #/ my $y2 = $y1 + 6; if ((defined $SorM) && ($SorM eq "single")) {clearSelections($self)}; @@ -1258,14 +1546,17 @@ sub _drawSelectionBox { # this is conceptually based on Nomi Harris' Genotator sub _extractTags { my (@tagsref) = @_; my $tags = shift @tagsref; - my ($FeatureID, $strand, $source); + my ($FeatureID, $strand, $source, $start, $stop, $offset); foreach my $tag(@{$tags}){ if ($tag =~ /^(FID.+)/) {$FeatureID = $1} if ($tag =~ /^Source (.+)/){$source = $1} if ($tag =~ /^Strand (.+)/){$strand = $1} + if ($tag =~ /^_SC_start (.+)/){$start = $1} + if ($tag =~ /^_SC_stop (.+)/){$stop = $1} + if ($tag =~ /^_SC_offset (.+)/){$offset = $1} + } - #print "tags were $FeatureID, $strand, $source\n\n"; - return ($FeatureID, $strand, $source); + return ($FeatureID, $strand, $source, $start, $stop, $offset); } sub _isLabel { @@ -1288,119 +1579,210 @@ sub _isLabel { =head2 mapFeatures Title : mapFeatures - Usage : $FeatureIDs = $MapObj->mapFeatures('draft'|'finished', + Usage : $FeatureIDs = $MapObj->mapFeatures('draft'|'finished'|undef, \@FeatureObj) - Function : map SeqFeature objects to the 'draft'(white) or - 'finished' (blue) maps + Function : map SeqFeature objects. Objects which are GeneStructureI compliant + will be broken down and their individual features mapped onto + the draft map according to their source_tag, and on the finished + map according to which Transcript(s) they participate in. + N.B. 'draft' versus 'finished' is now ignored but is retained + in the call for backwards compatibility with SeqCanvas v1.0. Returns : reference to a list of the FeatureID's of the mapped Features - Args : 'draft'|'finished', \@FeatureObj + Args : 'draft'|'finished'|undef, \@FeatureObj =cut -#' + sub mapFeatures { my ($self, $whichmap, $features) = @_; - my ($map, $canvas, $offsets); - if ($whichmap eq 'draft'){ - $map = $self->DraftMap; - $canvas = $self->DraftCanvas; - } elsif ($whichmap eq 'finished'){ - $map = $self->FinishedMap; - $canvas = $self->FinishedCanvas; - } else {print "no such map type $whichmap\n"; return} + my ($map, $canvas, @IDs); + $self->_processSeqFeatures($features); + + # need to map the draft features first in order to assign the colors to the source-tags + foreach my $feature(@{$features}){ + my @sub_features = $self->_getAllSubFeatures($feature); + push @IDs, ($self->_mapOntoDraft(\@sub_features)); + } + + # now map any gene-objects and their transcripts + push @IDs, ($self->_mapOntoFinished($features)); - my @coords; + return @IDs; +} + + +sub _mapOntoDraft { + + my ($self, $features)=@_; my @MappedIDs; + foreach my $feature(@{$features}) { - next if ($feature->primary_tag eq "source"); # this just gives one BIIIG line representing the entire sequence - next if ($feature->primary_tag eq "CDS_span"); # these are on strand 0 so should be chucked (or?) - next if ($feature->primary_tag eq "intron"); # these are ugly to map - next if ($feature->primary_tag eq "gene_span"); # these are apparently redundant to the tag "gene" - next if ($feature->primary_tag eq "CDS"); - my @tags; + next if ($feature->primary_tag eq "source"); # this just gives one BIIIG line representing the entire sequence after a genbank parse + next if ($feature->primary_tag eq "CDS_span"); # these are on strand 0 so should be chucked (or?) + next if ($feature->primary_tag eq "intron"); # these are simply too ugly to map + next if ($feature->primary_tag eq "gene_span"); # these are apparently redundant to the tag "gene" + next if ($feature->primary_tag eq "CDS"); + next if ($feature->primary_tag eq "gene"); + next if ($feature->can("transcripts")); # don't map genes (::Gene::GeneStructureI compliant objects) + next if ($feature->can("exons")); # don't map transcripts (::Gene::TranscriptI compliant objects) + + push @{$self->IndexedFeatureList}, $feature; # push the reference to this feature onto the indexed list + + my $offset; + $self->_check_and_expand_draft_canvas($feature->source_tag); # checks source, and assigns new offset & color to that source if it is new. Also expands the canvas & resets scrollbars to accomodate new size + $offset = $self->current_offsets->{$feature->source_tag}; + my $FeatureID = $self->next_id; # get next available index number + my $FID = "FID$FeatureID"; # just to remind us that this is now the widget designation not the index number + $self->_drawFeature($self->DraftMap, $self->DraftCanvas, $offset, $FID, $self->_parse_feature_info($feature, $FID, $offset,'draft')); + + push @MappedIDs, "$FID"; - push @{$self->IndexedFeatureList}, $feature; # push the reference to this feature onto the indexed list - my $FeatureID = $self->next_id; # get next available index number - my $FID = "FID$FeatureID"; # just to remind us that this is now the widget designation not the index number + } # end of the foreach $feature loop + + return @MappedIDs; - push @tags, $FID; # assign that ID to this on-screen widget +} - my $start = $feature->start; # get various useful goodies for mapping - my $end = $feature->end; - my $source = $feature->source_tag; - my $type = $feature->primary_tag; - my $id; # this may be undefined at the end of the routine if this particular feature is not a gene-type-feature - if ($feature->primary_tag eq "gene") {$source = "gene"} - # because the BioSeq parser calls *everything* a top-level gene feature - # we shift (IMHO) "real" top-level features out to a unique source-line 'gene' - # to prevent over-drawing sub-feature objects. Also grab the 'id' tag if it exists... - my $offset = $self->current_offsets->{$source}; - my $color = $self->current_colors->{$source}; - - my $strand = $feature->strand; - $strand =~ s/\+/1/; # these change GFF format strand designations into BioPerl Seq object strand desig. - $strand =~ s/-$/-1/; # But really... BioPerl should adopt GFF formats one day - The GFF designations are - $strand =~ s/\./0/; # much more intuitive (IMHO) - - if ($feature->has_tag("id")){my ($value) = $feature->each_tag_value("id"); - push @tags, "DB_ID " . $value} # this is to 'link' this widget to an an external database if desired. - # DB_ID should be the unique index number of that DB entry - push @tags, "Source $source"; # push the source so that we can retrieve the offset and color later if necessary - push @tags, "Strand $strand"; - push @tags, "Type $type"; # this holds the info about what type of Feature it is... comes from Primary tag... - push @tags, "Canvas $whichmap"; # let the widget know which map it is sitting on - #print "$FeatureID - primary " . $feature->primary_tag . " source " . $feature->source_tag . " strand " . $feature->strand . " start " . $feature->start . " offset $offset color $color\n"; - - - - if ($strand eq "-1") { - push @coords, [$end, $start]; - if ( (!($self->label)) or (!($feature->has_tag($self->label))) ){ # if no labels, or if this feature doesn't have the label then map without labelling - $map->MapObject(\@coords, '-ataxis' => $offset, - '-color' => $color, '-tags' => \@tags); - } else { - my ($label) = $feature->each_tag_value($self->label); # if the user has defined a tag they wish to label, and if that tag exists, then create a label - $map->MapObject(\@coords, '-ataxis' => $offset, '-label' => $label, '-labelcolor' => $color, - '-color' => $color, '-tags' => \@tags); - } - - } else { - push @coords, [$start, $end]; - if ((!($self->label)) or (!($feature->has_tag($self->label)))){ - $map->MapObject(\@coords, '-ataxis' => -$offset, - '-color' => $color, '-tags' => \@tags); +sub _mapOntoFinished { + + my ($self, $genes)=@_; + my @MappedIDs; + + foreach my $gene(@{$genes}) { + next if (!($gene->can("transcripts")) && ($gene->primary_tag ne "gene")); # all ::Gene::GeneStructureI objects should have this method, ignore them if they don't + # the problem is that for compliance with SeqIO parsing of genbank files I have to accomodate + # the primary_tag "gene" as well... hopefully this will change one day. + push @{$self->IndexedFeatureList}, $gene; # push the reference to this feature onto the indexed list + + my $offset; + if ($gene->{SeqCanvas_offset}){ # transcript objects are given this tag as they are loaded up upon SeqCanvas initialization + ($offset) = $gene->{SeqCanvas_offset}; + } else { # in principle this should never ever happen + ($offset) = 10; # but just in case... + } + + my $FeatureID = $self->next_id; # get next available index number + my $pFID = "FID$FeatureID"; # just to remind us that this is now the widget designation not the index number + $self->_drawFeature($self->FinishedMap, $self->FinishedCanvas, $offset, $pFID, $self->_parse_feature_info($gene, $pFID, $offset,'finished')); # and map it + push @MappedIDs, "$pFID"; + next if (!($gene->can("transcripts"))); # get out at this point if it is not a GeneStructureI compliant object. + foreach my $transcript($gene->transcripts){ # take each transcript + my $offset; + # the transcripts *should* have been assigned an offset already if we have gone this far, but just in case... + if ($transcript->{SeqCanvas_offset}){ # transcript objects are given this tag as they are loaded up upon SeqCanvas initialization + ($offset) = $transcript->{SeqCanvas_offset}; } else { - my ($label) = $feature->each_tag_value($self->label); - $map->MapObject(\@coords, '-ataxis' => -$offset, '-label' => $label, '-labelcolor' => $color, - '-color' => $color, '-tags' => \@tags); + next # then something has got totally screwed! } - } - @coords = () ; # reset for next iteration through features - - $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'single')}); # clicking the left mouse selects a single widget - $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets - $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only - $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases - $canvas->bind("$FID", '', sub{$canvas->dtag("Mouse_over");$canvas->addtag("Mouse_over", "withtag", $FID)}); # mouse-enter over a given feature will add a unique "mouse_over" tag - $canvas->bind("$FID", '', sub{$canvas->dtag("Mouse_over")}); # leaving that widget will delete this tag - # This can be examined via a call to selectWithtag("mouse_over") event in the - # top-level windowing system - - push @MappedIDs, "$FID"; - - + foreach my $exon($transcript->exons){ + my $FeatureID = $self->next_id; # get next available index number + my $FID = "FID$FeatureID"; # just to remind us that this is now the widget designation not the index number + $self->_drawFeature($self->FinishedMap, $self->FinishedCanvas, $offset, $FID, $self->_parse_feature_info($exon, $FID, $offset,'finished'), "Child_of_$FID"); + push @MappedIDs, "$FID"; + push @{$self->IndexedFeatureList}, $exon; # push the reference to this feature onto the indexed list + } + foreach my $promotor($transcript->promoters){ + my $FeatureID = $self->next_id; # get next available index number + my $FID = "FID$FeatureID"; # just to remind us that this is now the widget designation not the index number + push @MappedIDs, "$FID"; + push @{$self->IndexedFeatureList}, $promotor; # push the reference to this feature onto the indexed list + $self->_drawFeature($self->FinishedMap, $self->FinishedCanvas, $offset, $FID, $self->_parse_feature_info($promotor, $FID, $offset,'finished'), "Child_of_$FID"); + } + if ($transcript->poly_A_site){ + my $polyA = $transcript->poly_A_site; + my $FeatureID = $self->next_id; # get next available index number + my $FID = "FID$FeatureID"; # just to remind us that this is now the widget designation not the index number + push @{$self->IndexedFeatureList}, $polyA; # push the reference to this feature onto the indexed list + $self->_drawFeature($self->FinishedMap, $self->FinishedCanvas, $offset, $FID, $self->_parse_feature_info($polyA, $FID, $offset,'finished'), "Child_of_$FID"); + push @MappedIDs, "$FID"; + } + } } # end of the foreach $feature loop - return \@MappedIDs; + return @MappedIDs; } +sub _parse_feature_info { + my ($self, $feature, $FID, $offset,$whichmap) = @_; + my @tags; + my $start = $feature->start; # get various useful goodies for mapping + my $end = $feature->end; + my $source = $feature->source_tag; + my $type = $feature->primary_tag; + my $label; + if ($feature->has_tag($self->label)){ + ($label) = ($self->label)?$feature->each_tag_value($self->label):undef; # set the label if it is required and present + } else {$label = undef} + if (($feature->primary_tag eq "gene") || ($feature->primary_tag eq "genestructure")) {$source = "gene"} + my $strand = $feature->strand; + $strand =~ s/\+/1/; # these change GFF format strand designations into BioPerl Seq object strand desig. + $strand =~ s/-$/-1/; # But really... BioPerl should adopt GFF formats one day - The GFF designations are + $strand =~ s/\./0/; # much more intuitive (IMHO) + if ($feature->has_tag("id")){push @tags, "DB_ID " . $feature->each_tag_value("id")} # this is to 'link' this widget to an an external database if desired. + push @tags, $FID; # assign that ID to this on-screen widget + push @tags, "Source $source"; # push the source so that we can retrieve the offset and color later if necessary + push @tags, "Strand $strand"; + push @tags, "Type $type"; # this holds the info about what type of Feature it is... comes from Primary tag... + push @tags, "Canvas $whichmap"; # let the widget know which map it is sitting on + push @tags, "M_Ftr"; # this is a generic tag to indicate that this is a mapped feature - used to obtain the bounding box for mapped features which then sets the scrollregion + push @tags, "_SC_start $start"; # add the stop/start/offset to the object itself so that it knows where it is + push @tags, "_SC_stop $end"; # this info is used to draw the bounding boxes, etc. + push @tags, "_SC_offset $offset"; + + my $color = $self->current_colors->{$source}; + + return ($color, $label, $start, $end, $strand, @tags); # this is formatted to fit perfectly into the _drawFeature routine below + +} + + +sub _drawFeature { + my ($self, $map, $canvas, $offset, $FID, $color, $label, $start, $end, $strand, @tags ) = @_; + + my @coords; + + if ($strand eq "-1") { + push @coords, [$end, $start]; + if (!$label){ # if no labels, or if this feature doesn't have the label then map without labelling + $map->MapObject(\@coords, '-ataxis' => $offset, + '-color' => $color, '-tags' => \@tags); + } else { + $map->MapObject(\@coords, '-ataxis' => $offset, '-label' => $label, '-labelcolor' => $color, + '-color' => $color, '-tags' => \@tags); + } + + } else { + push @coords, [$start, $end]; + if (!$label){ + $map->MapObject(\@coords, '-ataxis' => -$offset, + '-color' => $color, '-tags' => \@tags); + } else { + $map->MapObject(\@coords, '-ataxis' => -$offset, '-label' => $label, '-labelcolor' => $color, + '-color' => $color, '-tags' => \@tags); + } + } + + $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'single')}); # clicking the left mouse selects a single widget + $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets + $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only + $canvas->bind("$FID", '', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases + $canvas->bind("$FID", '', sub{$canvas->dtag("Mouse_over");$canvas->addtag("Mouse_over", "withtag", $FID)}); # mouse-enter over a given feature will add a unique "mouse_over" tag + $canvas->bind("$FID", '', sub{$canvas->dtag("Mouse_over")}); # leaving that widget will delete this tag + # This can be examined via a call to selectWithtag("mouse_over") event in the + # top-level windowing system + +} + + =head2 unmapFeatures Title : unmapFeatures Usage : my $FeatureObjsRef = $MapObj->unmapFeatures(\@FeatureIDs) - Function : to remove mapped features from the map display - Returns : referenced list of removed $FeatureObj objects + Function : to remove mapped features (and SubFeatures!!) from the map display + Returns : referenced list of removed $FeatureObj objects; + note that objects may appear in this list multiple times + if they appeared in more than one place on the map! =cut @@ -1408,17 +1790,33 @@ sub unmapFeatures { my ($self, $FeatureIDs) = @_; my @Features = @{$FeatureIDs}; my (@unmappedFeatures); - if ($#Features == -1) {return @unmappedFeatures}; + if ($#Features == -1) {return \@unmappedFeatures}; $self->clearSelections; foreach my $Feature (@Features){ - #print "deleting Feature $Feature\n"; - $self->DraftCanvas->delete($Feature); # delete the map widgets - $self->FinishedCanvas->delete($Feature); - my ($id)= $Feature =~ /FID(.+)/; - push @unmappedFeatures, $self->IndexedFeatureList->[$id]; # take the feature out of the encapsulated list and prepare to send it back to the caller + + $self->DraftCanvas->delete($Feature); # delete the map widgets + $self->FinishedCanvas->delete($Feature); + my ($id)= $Feature =~ /FID(.+)/; # need the id number to get the actual feature object + my $unmappedFeature = $self->IndexedFeatureList->[$id]; # get the feature + push @unmappedFeatures, $unmappedFeature; # and prepare to send it back to the caller + + foreach my $subfeature($self->_getAllSubFeatures($unmappedFeature)){ # now get any and all subfeatures and unmap them + my $x = scalar($subfeature); # they are identified by their scalar designations - e.g. Bio::SeqFeature::Generic=HASH(0x89e2fec) + my $pos = 0; # counter to show where we are in the indexed feature list + foreach my $indF(@{$self->IndexedFeatureList}){ # iterate through teh feature list + my $y = scalar($indF); # make a scalar from that feature id + if ($x eq $y){ + $self->DraftCanvas->delete("FID$pos"); + $self->FinishedCanvas->delete("FID$pos"); # if it is the same, then delete that feature + push @unmappedFeatures, $self->IndexedFeatureList->[$id]; # get the feature + undef $self->IndexedFeatureList->[$pos]; # and remove it from the feature list + } + ++$pos + } + } undef $self->IndexedFeatureList->[$id]; # delete it from the encapsulated list - } + } return \@unmappedFeatures } @@ -1442,8 +1840,6 @@ sub getSelectedIDs { } -=pod - =head2 getSelectedTags Title : getSelectedTags @@ -1465,14 +1861,20 @@ sub getSelectedTags { my $Fcanvas = $self->FinishedCanvas; my (@selected, $FeatureID, $source, $strand, $type, $canvas, $DB_ID); my $widget; - + my $whichmap = "draft"; # set this as the default at the beginning, if the selected feature is on the finished map we will change it #check the Draft and Finished canvasses for selected - @selected = ($Dcanvas->find("withtag", "selected"),$Fcanvas->find("withtag", "selected")); # find all Widget ID's that have a "selected" tag - if (@selected) { - $widget=shift @selected; + @selected = $Dcanvas->find("withtag", "selected"); # find all Widget ID's that have a "selected" tag + if ((scalar @selected) == 0){ + @selected = $Fcanvas->find("withtag", "selected"); # if there is nothign on the draft, perhaps there is something on the finished + $whichmap = "finished"; # update our flag } - my @tags = $Dcanvas->gettags($widget); - if (not @tags) {$Fcanvas->gettags($widget)} + return if ((scalar @selected) == 0); # if not, then get out + + $widget=shift @selected; # get this widget (single widget only!) + + my @tags; + if ($whichmap eq "draft"){@tags = $Dcanvas->gettags($widget)} + else {@tags = $Fcanvas->gettags($widget)} # for each widget, extract all tags associated with that widget foreach my $tag(@tags){ if ($tag =~ /^(FID.+)/) {$FeatureID = $1} @@ -1486,10 +1888,8 @@ sub getSelectedTags { return ($FeatureID, $strand, $source, $type, $canvas, $DB_ID); # note that this returns only the values for the last-parsed widget!! } -=pod - =head2 getIDsWithTag - + Title : getIDsWithTag Usage : $FeatureIDs = $MapObj->getIDsWithTag(\@taglist) Function : to retrieve the FeatureID's of all currently selected mapped objects @@ -1576,7 +1976,7 @@ sub getFeaturesWithTag { my (%FeatureHash, @selected); if ($#whichtags == -1){return \%FeatureHash}; # returns an empty hash if there were no parameters sent - foreach my $whichtag(@whichtags){ + foreach my $whichtag(@whichtags){ my $Dcanvas = $self->DraftCanvas; my $Fcanvas = $self->FinishedCanvas; @selected = $Dcanvas->find("withtag", $whichtag); # find all DRAFT Widget ID's that have a "selected" tag @@ -1587,7 +1987,7 @@ sub getFeaturesWithTag { next if (!$FeatureID); my $FeatureIndex = $1; my $feature = $self->IndexedFeatureList->[$FeatureIndex]; # extract this Bio::Feature object from the indexed list - $FeatureHash{$FeatureID} = $feature; # stick it in the hash to be returned to the user + $FeatureHash{"$FeatureID"} = $feature; # stick it in the hash to be returned to the user } @selected = $Fcanvas->find("withtag", $whichtag); # find all FINISHED Widget ID's that have a "selected" tag foreach my $widget(@selected){ @@ -1634,7 +2034,7 @@ sub clearSelections { FeatureIDs (of the form FIDnnn where nnn is a unique integer) =cut -#' + sub selectFeatures { my $self = shift @_; @@ -1779,8 +2179,7 @@ sub assignCustomColors { sub { my $color = $_[1]; $self->current_colors->{$source} = $color; - #print "new color for $source is " , - # $self->current_colors->{$source} . "\n"; + $self->recolorWithTag('default', 'draft', ["Source $source"]); $self->recolorWithTag('default', 'finished', ["Source $source"]); $cedit->destroy;