Bio::Tk SeqCanvas
SummaryPackage variablesSynopsisDescriptionGeneral documentationMethods
Toolbar
WebCvs
Summary
Bio::Tk::SeqCanvas.pm - (v3.0) Graphical display of SeqI objects
Package variables
Globals (from "use vars" definitions)
$AUTOLOAD
Privates (from "my" definitions)
@colorlist = qw(darkblue yellowgreen fuschia orange purple dkgreen chartreuse lightblue magenta turquoise green yellow brown ltgreen)
%colordef = ( magenta => '#ee00ee', fuschia => '#ff00cc', red => '#ff1100', pink => '#ffdddd', orange => '#ffaa00', yellow => '#eed007', purple => '#bb00ff', darkblue => '#3300ee', lightblue => '#99bbee', turquoise => '#00ddcc', green => '#11dd11', chartreuse => '#aacc00', yellowgreen => '#669900', black => '#000000', brown => '#994444', dkgreen => '#00aa00', ltgreen => '#aaeeaa', )
$dxa;
$dxb;
$ori;
$_color_pos = 0
$dya;
$dyb;
$_nextDoffset = 0
@FinishedSourceLabels;
$_nextFoffset = 0
@Sources;
%colors;
%AllFeatures;
Included modules
Bio::SeqFeature::Gene::Exon
Bio::SeqFeature::Gene::GeneStructure
Bio::SeqFeature::Gene::Transcript
Bio::SeqI
Bio::SeqIO
Bio::Tk::AnnotMap
Bio::Tk::SeqCanvasFeature
Carp
Tk
Tk::DragDrop
Tk::DropSite
Tk::widgets qw ( ColorEditor Dialog )
strict
Synopsis
 # To create a BioSeq map and return a handle to the map object:
use Tk;
use Bio::SeqIO;
use Bio::Tk::SeqCanvas;
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 # (note: the test file used below is in the /t/ folder) my $SIO = Bio::SeqIO->new(-file=> 'testseq.gb', -format => 'genbank'); my $SeqObj = $SIO->next_seq(); # Draw the Map my $axis_length = 800; # how large (long axis) I want the final map to be my $MapObj = Bio::Tk::SeqCanvas->new( $axis_length, $Frame, $lblSysMess, $SeqObj, -orientation => 'horizontal', label => 'primary_tag', width => 200, ); }
Description
Creates an interactive scalable/zoomable map of all features and
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 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.
Methods
dxa
No description
Code
dya
No description
Code
dxb
No description
Code
dyb
No description
Code
_accessible
No description
Code
_default_for
No description
Code
_standard_keys
No description
Code
FinishedSources
No description
Code
DraftSources
No description
Code
AllFeatures
No description
Code
FinishedSourceLabels
No description
Code
addFinishedSourceLabel
No description
Code
Sources
No description
Code
addSource
No description
Code
colorlist
No description
Code
colordef
No description
Code
MapArgs
No description
Code
ori
No description
Code
next_draft_offset
No description
Code
next_finished_offset
No description
Code
draft_offset_pointer
No description
Code
finished_offset_pointer
No description
Code
current_colors
No description
Code
next_colorpos
No description
Code
Tk::Error
No description
Code
subseq
No description
Code
end
No description
Code
DESTROY
No description
Code
localDestroy
No description
Code
AUTOLOAD
No description
Code
newDescriptionCode
activeDeleteDescriptionCode
_addMenus
No description
Code
reCastAs
No description
Code
_deleteFeatureFromSeqObject
No description
Code
_setupDrag_n_Drop
No description
Code
_start_DnD_Drag
No description
Code
_examine_DnD_Motion
No description
Code
_DnD_Drop
No description
Code
_bindDropEvent
No description
Code
_receiveDropOnWidget
No description
Code
_receiveDropCreateNewGene
No description
Code
_bindMultiSelection
No description
Code
_setupAxes
No description
Code
DoZoom
No description
Code
_processSeqFeatures
No description
Code
_check_and_expand_draft_canvas
No description
Code
_extract_transcripts
No description
Code
_check_and_expand_finished_canvas
No description
Code
_extract_sources
No description
Code
_getAllSubFeatures
No description
Code
_drawFinishedLabels
No description
Code
_drawDraftLabels
No description
Code
_selectFeature
No description
Code
_drawSelectionBox
No description
Code
_extractTags
No description
Code
_isLabel
No description
Code
mapFeaturesDescriptionCode
_mapOntoFinished
No description
Code
_setupGeneBindings
No description
Code
_setupTranscriptBindings
No description
Code
_setupExonBindings
No description
Code
_setupPromotorBindings
No description
Code
_setupPolyABindings
No description
Code
_setupDraftBindings
No description
Code
_mapOntoDraft
No description
Code
deleteFeatures
No description
Code
unmapFeaturesDescriptionCode
translateFeatureIntoSCF
No description
Code
getSelectedIDsDescriptionCode
getSelectedTagsDescriptionCode
getIDsWithTagDescriptionCode
getSelectedFeaturesDescriptionCode
getFeaturesWithTagDescriptionCode
clearSelectionsDescriptionCode
selectFeaturesDescriptionCode
selectWithTagDescriptionCode
recolorWithTagDescriptionCode
assignCustomColorsDescriptionCode
is_draft_featureDescriptionCode
is_finished_featureDescriptionCode
Methods description
newcode    nextTop
 Title    : new
Usage : $MapObj= SeqCanvas->new(
$axis_length,
$Frame,
[$lblSysMess | undef],
$SeqObj,
-orientation => ['horizontal'|'vertical']
[, label => $tag])
Function : create a map from the Feature object provided Returns : Handle to the Map object Args : axis_length in pixels, a Tk::Frame object, 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
activeDeletecodeprevnextTop
 Title    : activeDelete
Usage : $MapObj->activeDelete("on" | "off")
Function : enable/disable 'delete' key to delete mapped features (default off)
Returns :
Args : "on" | "off" (case sensitive)
mapFeaturescodeprevnextTop
 Title    : mapFeatures
Usage : $FeatureIDs = $MapObj->mapFeatures('draft'|'finished'|undef,
\@FeatureObj)
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'|undef, \@FeatureObj
unmapFeaturescodeprevnextTop
 Title    : unmapFeatures
Usage : my $FeatureObjsRef = $MapObj->unmapFeatures(\@FeatureIDs)
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!
getSelectedIDscodeprevnextTop
 Title    : getSelectedIDs
Usage : $FeatureIDs = $MapObj->getSelectedIDs
Function : to retrieve the FeatureID's of
all currently selected mapped objects
Returns : reference to a list of FeatureID's
Args : none
getSelectedTagscodeprevnextTop
 Title   : getSelectedTags
Usage : ($FeatureID, $strand, $source,
$type, $canvas [, $DB_ID]) = $MapObj->getSelectedTags
Returns : FeatureID, # the id of the mapped widget
Strand, # BioPerl strand 1,0,-1
Source, # source_tag
Type, # primary_tag
Canvas, # 'draft' or 'finished'
Database_Index # if available
Comment : This is to be used for single-selection events only!
Args : none
getIDsWithTagcodeprevnextTop
 Title    : getIDsWithTag
Usage : $FeatureIDs = $MapObj->getIDsWithTag(\@taglist)
Function : to retrieve the FeatureID's of all currently selected mapped objects
Returns : reference to a list of FeatureID's
Args : a reference to a list of tags (see discussion of proper tag format above)
getSelectedFeaturescodeprevnextTop
 Title   : getSelectedFeatures
Usage : $FeatureHashRef = $MapObj->getSelectedFeatures
Returns : a reference to a hash where the FeatureID is the key,
and the Bio::SeqFeature Object is the value
Args : none
getFeaturesWithTagcodeprevnextTop
 Title   : getFeaturesWithTag
Usage : $FeatureHashRef = $MapObj->getFeaturesWithTag(\@taglist)
Returns : a reference to a hash where the FeatureID is the
key, and the Bio::SeqFeature Object is the value
Args : reference to a list of valid tags
(see discussion of proper tag format)
clearSelectionscodeprevnextTop
 Title    : clearSelections
Usage : $MapObj->clearSelections
Function : Clear all selection boxes and "selected" status of all Features.
Returns : nothing
Args : none
selectFeaturescodeprevnextTop
 Title    : selectFeatures
Usage : $MapObj->selectFeatures(\@FeatureIDs)
Function : "select" all Features with @FeatureID id's
Args : @FeatureIDs - a list of valid
FeatureIDs (of the form FIDnnn where nnn is a unique integer)
selectWithTagcodeprevnextTop
 Title    : selectWithTag
Usage : $MapObj->selectWithTag(\@tag_list [,'draft'|'finished'])
Function : "select" all features which have any of @tag_list tags.
Args : @taglist, and optional 'draft' or 'finished' which map
recolorWithTagcodeprevnextTop
 Title    : recolorWithTag
Usage : $MapObj->recolorWithTag('#XXXXXX'|'default', 'draft'|'finished', \@tag_list)
Function : change the color of mapped objects having one of @tag_list tags.
Returns : nothing
Args :
First arg:hex-reference to an RGB color value, or 'default'.
Second arg: the canvas ('draft', or 'finished')
Third arg: a referenced list of tags.
assignCustomColorscodeprevnextTop
 Title    : assignCustomColors
Usage : $MapObj->assignCustomColors($top)
Function : change the default map-color for a selected widgets "Source" tag.
Returns : nothing
Args : a reference to a Tk::MainWindow object (new or existing).
is_draft_featurecodeprevnextTop
 Title    : is_draft_feature
Usage : $result = $MapObj->is_draft_feature($FeatureID)
Function : check if a $FeatureID is on the draft (white) map.
Returns : 1 for true, undef for false
Args : the FeatureID you are querying
is_finished_featurecodeprevnextTop
 Title    : is_finished_feature
Usage : $result = $MapObj->is_finished_feature($FeatureID)
Function : check if $FeatureID is on the finished (blue) map.
Returns : 1 for true, undef for false
Args : the FeatureID you are querying
Methods code
dxadescriptionprevnextTop
sub dxa {
		my ($self, $newval) = @_;
		if ($newval){$dxa = $newval}
		$dxa=0 unless $dxa;
		return $dxa;
}
dyadescriptionprevnextTop
sub dya {
		my ($self, $newval) = @_;
		if ($newval){$dya = $newval}
		$dya=0 unless $dya;
		return $dya;
}
dxbdescriptionprevnextTop
sub dxb {
		my ($self, $newval) = @_;
		if ($newval){$dxb = $newval}
		$dxb=0 unless $dxb;
		return $dxb;
}
dybdescriptionprevnextTop
sub dyb {
		my ($self, $newval) = @_;
		if ($newval){$dyb = $newval}
		$dyb=0 unless $dyb;
		return $dyb;
	}
	
	#___________________________________________________________
#ATTRIBUTES
my %_attr_data = # DEFAULT ACCESSIBILITY
( #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'], BioPerlFeatureTypes => [{ "Gene" => "Bio::SeqFeature::Gene::GeneStructure", "Transcript" => "Bio::SeqFeature::Gene::Transcript", "Exon" => "Bio::SeqFeature::Gene::Exon", "Intron" => "Bio::SeqFeature::Gene::Intron", "Promoter" => "Bio::SeqFeature::Gene::Promoter", "Poly_A_site" => "Bio::SeqFeature::Gene::Poly_A_site", "UTR" => "Bio::SeqFeature::Gene::UTR", "Non-Coding" => "Bio::SeqFeature::Gene::NC_Feature", }, 'read/write'], Menu => [undef, 'read/write'], # the menu that contains "Re-Cast Selected As", to allow additions from outside of the module
ReCastMenu => [undef, 'read/write'], # the menu that is cascaded by selecting Re-CastSelected As" to allow re-configuration of callbacks from outside if you are not using generic BioPerl feature objects
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 => [undef, 'read/write'], whitespace => [10, 'read'], # whitespace is the distance between the axis and the first widget; the default never changes
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'], _activeDelete => ["off", 'read/write'], # does pressing the delete key delete the selected features?
DropHighlighted => [undef, 'read/write'], # this gets set during a drag-n-drop motion event, it holds the FID of a currently mouse-drag-over feature
); my $_nextDoffset=0; my $_nextFoffset=0; # 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; my %AllFeatures; # this is the list of features mapped onto the canvas, key is the stringified feature hash address, value is the feature object
#_____________________________________________________________
#METHODS, to operate on encapsulated class data
# Is a specified object attribute accessible in a given mode
}
_accessibledescriptionprevnextTop
sub _accessible {
	my ($self, $attr, $mode) = @_;
    return 0 unless ($_attr_data{$attr}[1] &&  $mode);
	$_attr_data{$attr}[1] =~ /$mode/
    }

    # Classwide default value for a specified object attribute
}
_default_fordescriptionprevnextTop
sub _default_for {
	my ($self, $attr) = @_;
	$_attr_data{$attr}[0];
    }

    # List of names of all specified object attributes
}
_standard_keysdescriptionprevnextTop
sub _standard_keys {
	keys %_attr_data;
}
FinishedSourcesdescriptionprevnextTop
sub FinishedSources {
    # for backwards compatibility    	return \@FinishedSourceLabels;
}
DraftSourcesdescriptionprevnextTop
sub DraftSources {
       # for backwards compatibility    	return \@Sources;
}
AllFeaturesdescriptionprevnextTop
sub AllFeatures {
    	# this is the hash of the unique FeatureID and associated SeqCanvasFeature value.
# can be called three ways:
#->AllFeatures($FID, $SCF) sets the value
#->AllFeatures($FID) returns the single value
#->AllFeatures() returns all values
my ($self, $FID, $SeqCanvasFeature) = @_; if ($SeqCanvasFeature){ $AllFeatures{$FID} = $SeqCanvasFeature; return 1; } # the stringified address of the hash is the key, the feature is the value
if ($FID){ return $AllFeatures{$FID} } return\% AllFeatures
}
FinishedSourceLabelsdescriptionprevnextTop
sub FinishedSourceLabels {
  # this is a get/set    	my ($self, @labels) = @_;
if (scalar @labels){@FinishedSourceLabels = @labels} return @FinishedSourceLabels;
}
addFinishedSourceLabeldescriptionprevnextTop
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;
}
SourcesdescriptionprevnextTop
sub Sources {
    	my ($self, @sources) = @_;
    	if (scalar @sources){@Sources = @sources}
        return 	@Sources;
}
addSourcedescriptionprevnextTop
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;
}
colorlistdescriptionprevnextTop
sub colorlist {
    	return @colorlist
}
colordefdescriptionprevnextTop
sub colordef {
    	return %colordef
}
MapArgsdescriptionprevnextTop
sub MapArgs {
    	my ($self) = @_;
    	my %_map_args;
    	foreach my $key ($self->_standard_keys) {
    		
    		if ($key =~ /^-/) {
    			$_map_args{$key} = $self->{$key};
    		}
    	}
    	return %_map_args;
    }

    #sub next_id {
# return $_nextid++;
#}
my $ori;
}
oridescriptionprevnextTop
sub ori {
   # the orientation of the canvas has been set... horizontal or vertical.		my ($self, $val) = @_;
$ori = $val if $val; return $ori;
}
next_draft_offsetdescriptionprevnextTop
sub next_draft_offset {
    	if (!$_nextDoffset){$_nextDoffset=2}
    	return $_nextDoffset++;     # in this case increment it
}
next_finished_offsetdescriptionprevnextTop
sub next_finished_offset {
    	if (!$_nextFoffset){$_nextFoffset=2}
    	return $_nextFoffset++;     # in this case increment it
}
draft_offset_pointerdescriptionprevnextTop
sub draft_offset_pointer {
    	if (!$_nextDoffset){$_nextDoffset = 2}
    	return $_nextDoffset;       # in this case just send it as it is
}
finished_offset_pointerdescriptionprevnextTop
sub finished_offset_pointer {
    	if (!$_nextFoffset){$_nextFoffset = 2}
    	return $_nextFoffset;       # in this case just send it as it is
} #sub current_offsets {
# return \%offsets;
#
}
current_colorsdescriptionprevnextTop
sub current_colors {
    	return\% colors;
}
next_colorposdescriptionprevnextTop
sub next_colorpos {
        my $pos = $_color_pos;
        ++$_color_pos;
        if (!$colorlist[$_color_pos]){$_color_pos = 0}    # if we are beyond the end of the colorlist then return the pointer to zero
return $pos; }
}
Tk::ErrordescriptionprevnextTop
sub Tk::Error {
	Tk->break;
}
subseqdescriptionprevnextTop
sub subseq {
    my ($self,@args)=@_;
    return $self->MapSeq->subseq(@args);
}
enddescriptionprevnextTop
sub end {
return $_[0]->MapSeq->end;
}
DESTROYdescriptionprevnextTop
sub DESTROY {
}
localDestroydescriptionprevnextTop
sub localDestroy {
	my ($self) = @_;	
	if ($self->Menu){eval {$self->Menu->destroy}}
	if ($self->ReCastMenu){eval {$self->ReCastMenu->destroy}}
    eval {$self->FinishedCanvas->destroy};
    eval {$self->DraftCanvas->destroy};
    eval {$self->destroy};
}
AUTOLOADdescriptionprevnextTop
sub AUTOLOAD {
    no strict "refs";
    my ($self, $newval) = @_;

    $AUTOLOAD =~ /.*::(\w+)/;

    my $attr=$1;
    if ($self->_accessible($attr,'write')) {

	*{$AUTOLOAD} = sub {
	    if ($_[1]) { $_[0]->{$attr} = $_[1] }
	    return $_[0]->{$attr};
	};    ### end of created subroutine
### this is called first time only
if ($newval) { $self->{$attr} = $newval } return $self->{$attr}; } elsif ($self->_accessible($attr,'read')) { *{$AUTOLOAD} = sub { return $_[0]->{$attr} }; ### end of created subroutine
return $self->{$attr} } # Must have been a mistake then...
croak "No such method: $AUTOLOAD"; } #__________________________________________________________________________________
# Object Methods
#__________________________________________________________________________________
}
newdescriptionprevnextTop
sub new {
    # returns object reference for success	
# returns -1 for failed initiation - no $SeqObj supplied
# returns -2 for wrong object type - must be (ISA) SeqI 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
# the reference to TOP in the next line is the top-level TK window.
# if this is passed as 'defined' then a Tk::Label object with the name
# lblSysMess ***MUST*** exist in this window to receive output
# messages from this module. If $TOP is undefined this feature is disabled.
my ($caller, $window_length, $frame, $TOP, $SeqObj, %args) = @_; my $caller_is_obj = ref($caller); my $class = $caller_is_obj || $caller; # check incoming data for validity
if (!$SeqObj){return -1} if (!$SeqObj->isa("Bio::SeqI")) {return -2} if ($SeqObj->length == 0) {return -3} if (!$frame->isa("Tk::Frame")){return -5} #Create Object
my $self = bless {}, $class; if ($args{-orientation} =~ /h/i) {$self->{-orientation} = "horizontal"; $self->ori("horizontal")} elsif ($args{-orientation} =~ /v/i) {$self->{-orientation} = "vertical"; $self->ori("vertical")} else {return -4} delete $args{-orientation}; foreach my $attrname ( $self->_standard_keys ) { next if $attrname eq "-orientation"; if (exists $args{$attrname}) { $self->{$attrname} = $args{$attrname} } elsif ($caller_is_obj) { $self->{$attrname} = $caller->{$attrname} } else { $self->{$attrname} = $self->_default_for($attrname) } } $self->SysMess($TOP); # a handle out to the top-level window system for passing messages
# 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', -expand => 1, -fill => "both")); # the sub-frame to hold the two maps
$self->MapSeq($SeqObj); # SeqCanvas contains the sequence object
# *******************************
# - This line ensures that the sequences fills the allocated space.
$self->{-range} = [0, ($SeqObj->length)]; # 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
# $self->total_offset
# ************************************************************
# ***********************************************************
# Create the MapCanvases with correct dimensions
my $map_width; # remember, $self->dxa/dya are *class* variables, not instance varaibles!
$map_width = (2* ($self->whitespace + ($self->draft_offset_pointer*$self->def_offset))); if ($map_width < 200){$map_width = 200} if ($self->{-orientation} eq "horizontal") { # the SeqText widget breaks MS-Windows, and is of questionable value anyway...
# I have removed it, but if you are running *nix and create only horizontal
# maps you are free to uncomment these lines, as well as the reference in the
# initializing hash at the top of the code and any other lines that
# make reference to ->SeqText to make it appear again.
#$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->dxa(1);
$self->fxa(1); $self->dxb($window_length);# height is unchanged
$self->fxb($window_length);# height is unchanged
my $DLF = $self->MapFrame->Frame->pack(-side => 'top', -fill => 'both', -expand => 1); # frame for Draft map and labels
my $FLF = $self->MapFrame->Frame->pack(-side => 'top', -fill => 'both', -expand => 1); # frame for Finished map and labels
$self->DraftLabelCanvas($DLF->Canvas(-width => 100, -height => $map_width, -background => "#ffffff")->pack(-side => 'left', -fill => 'both', -expand => 1)); $self->DraftCanvas($DLF->Canvas(-width => $window_length, -height => $map_width, -background => "#ffffff")->pack(-side => 'left', -fill => 'both', -expand => 1)); my $Dyscrollbar = $DLF->Scrollbar('-orient' => 'vertical','-command' => sub {$self->DraftLabelCanvas->yview(@_);$self->DraftCanvas->yview(@_)})->pack(-side => 'left', '-fill'=>'y', '-expand' => 1); $self->FinishedLabelCanvas($FLF->Canvas(-width => 100, -height => $map_width, -background => "#eeeeff")->pack(-side => 'left', -fill => 'both', -expand => 1)); $self->FinishedCanvas($FLF->Canvas(-width => $window_length, -height => $map_width, -background => "#eeeeff")->pack(-side => 'left', -fill => 'both', -expand => 1)); my $Fyscrollbar = $FLF->Scrollbar('-orient' => 'vertical','-command' => sub {$self->FinishedLabelCanvas->yview(@_);$self->FinishedCanvas->yview(@_)})->pack(-side => 'left', '-fill'=>'y', '-expand' => 1); $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
$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->dya(1);
$self->fya(1); $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('<Enter>', sub { $self->DraftCanvas->Tk::focus; } ); # set focus on the appropriate map when mouse enters
$self->FinishedCanvas->Tk::bind('<Enter>', sub { $self->FinishedCanvas->Tk::focus; } ); # the space
if ($self->_activeDelete eq "on"){$self->DraftCanvas->Tk::bind("<KeyPress-Delete>", sub {$self->deleteFeatures([(keys %{$self->getSelectedFeatures})])} )} if ($self->_activeDelete eq "on"){$self->FinishedCanvas->Tk::bind("<KeyPress-Delete>", sub {$self->deleteFeatures([(keys %{$self->getSelectedFeatures})])} )}; # and now create the maps
$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
# now we have to deal with the elements of the ZOOM
my $zoomlabel = $self->ZoomFrame->Label(-text => "Zoom")->pack(-side => 'left'); $self->min_zoom($self->DraftMap->{scale_factor}); # the original maps display the entire sequence, therefore this is the minimum level of zoom
$self->max_zoom(2); # this is somewhat arbitrary...
my $min_scroll = 0; my $max_scroll = 100; $self->zoom_ratio( ($self->max_zoom - $self->min_zoom)/($max_scroll - $min_scroll)); #/ my $zoom_scale_length = ($self->{-orientation} eq 'horizontal')?$window_length:$map_width; # the zoom-scale spans the horizontal bottom of the window,
# the length of which depends on the orientation of the map
my $zoomscale = $self->ZoomFrame->Scale(-orient => 'horizontal', -sliderlength => 25, -length => $zoom_scale_length - 80, # the 80 pixels compensates for the "Zoom" label beside the widget
-width => 10, -from => 1, -to => 100, -showvalue => 0, -variable =>\$ self->{zoom_level}, -command => sub {$self->DoZoom()} ); $zoomscale->pack(-side => 'left', -expand => 'yes', -fill => 'x', -anchor => 'e'); $self->ZoomBar($zoomscale); $self->{zoom_level} = 5; $self->DoZoom; # initialize the canvas with the default rows & colors
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); } # draw the labels for default rows and colors
foreach my $source($self->Sources){ $self->_drawDraftLabels([$source]); } foreach my $label($self->FinishedSourceLabels){ $self->_drawFinishedLabels([$label]); } # now that everything is set up, go ahead and draw the features
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(); # this sets up teh mouse-bindings for the "rubber-band box" that snaps around multiple features
$self->_setupDrag_n_Drop(); # this sets up the basics of the drag n drop interface
my $toplevel = $self->DraftCanvas->toplevel; my $a = $toplevel->geometry; $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
$self->_addMenus; $self->MapFrame->OnDestroy(sub {&localDestroy($self)}); $self->{zoom_level} = 1; $self->DoZoom; # return the object handle
return $self;
}
activeDeletedescriptionprevnextTop
sub activeDelete {
	my ($self, $onoff) = @_;
	$self->_activeDelete($onoff);
    if ($self->_activeDelete eq "on"){
		$self->DraftCanvas->Tk::bind("<KeyPress-Delete>", sub {$self->deleteFeatures([(keys %{$self->getSelectedFeatures})])} );
	}else {
		$self->DraftCanvas->Tk::bind("<KeyPress-Delete>", sub {} );
	}
    if ($self->_activeDelete eq "on"){
		$self->FinishedCanvas->Tk::bind("<KeyPress-Delete>", sub {$self->deleteFeatures([(keys %{$self->getSelectedFeatures})])} );
	}else {
		$self->FinishedCanvas->Tk::bind("<KeyPress-Delete>", sub {} );
	}
}
_addMenusdescriptionprevnextTop
sub _addMenus {
	my ($self) = @_;
	
	#if ($self->Menu){eval {$self->Menu->destroy}}
#if ($self->ReCastMenu){eval {$self->ReCastMenu->destroy}}
my $canvas = $self->DraftCanvas; my $menu = $canvas->Menu(-type => 'normal', -tearoff => 0); my $cm = $menu->Menu(-type => 'normal', -tearoff => 0); foreach my $type (keys %{$self->BioPerlFeatureTypes()}) { $cm->add( 'command', -label => "$type", -command => sub {$self->reCastAs(${$self->BioPerlFeatureTypes}{$type});}, ); } my $f = $menu->add( 'cascade', -label => 'Re-Cast Selected As', -menu => $cm ); $self->Menu($menu); $self->ReCastMenu($cm); $canvas->Tk::bind ("<Button-3>" => sub {$self->Menu->Popup(-popover => 'cursor', -popanchor => 'nw'); });
}
reCastAsdescriptionprevnextTop
sub reCastAs {
	my ($self, $cast) = @_;
	my %FeatureHash = %{$self->getSelectedFeatures};
	my $newfeature; my @del_list; my @add_list;
	foreach my $FID (keys %FeatureHash){
		my $feature = $FeatureHash{$FID};
		$newfeature = $cast->new();  # make a new object of that type
$newfeature->_from_gff_string($feature->gff_string); # and fill it with the information from the existing feature::Generic
push @del_list, $feature; push @add_list, $newfeature; } $self->unmapFeatures([(keys %FeatureHash)]); $self->mapFeatures("draft",\@ add_list);
}
_deleteFeatureFromSeqObjectdescriptionprevnextTop
sub _deleteFeatureFromSeqObject {
	# called by unmapFeatures *exclusively*
# send this a feature and it will remove it from the seq object
# if it is represented on the map only once
# returns 0 if the feature was not deleted, 1 if it was.
my ($self, $delfeature) = @_; my $Seq = $self->MapSeq; my @features = (values %{$self->getFeaturesWithTag(["Canvas draft"])}); push @features, (values %{$self->getFeaturesWithTag(["Canvas finished"])}); # now we have a list of all features, check if the feature is a singleton, and if so, delete it
return 0 if (scalar (grep {$_ eq $delfeature} @features) > 1); # it is represented more than once on the map, so don't destroy it!
# okay, here we have to
@features = $Seq->all_SeqFeatures; $Seq->flush_SeqFeatures; foreach my $feature(@features){ next if ($feature eq $delfeature); # filter out the ones we don't want
$Seq->add_SeqFeature($feature); } return 1;
}
_setupDrag_n_DropdescriptionprevnextTop
sub _setupDrag_n_Drop {
	my ($self) = @_;
	my $source_canvas = $self->DraftCanvas;
	my $dest_canvas = $self->FinishedCanvas;  # note that Drag n Drop is unidirectional in Genquire
$dest_canvas->eventAdd('<<DROP>>','<Triple-Button-5>'); # define this as an event that I can trigger at will later on
$self->_bindDropEvent; # create a binding to deal with drops.
# create the drag-n-drop widget... this is the little label that moves as you drag; teh start_command subroutine is executed on the first movement
my $DnD_token; $DnD_token = $source_canvas->DragDrop ( # this is creating a label-like thing
-event => '<B2-Motion>', # drag and drop is accomplished with button *2* of the mouse
-sitetypes => ['Local'], # I will try "remote" one day, which should allow importing of features from one canvas to another
-startcommand => sub {my @idxs = @{$self->getSelectedIDs}; # see if anything is selected to drag
unless (scalar(@idxs) > 0){ # if nothing selected then abort
$DnD_token->configure(-text => "** nothing selected **"); $self->{validDnD} = 0; # set a flag so the drop routine knows to immediately abort
return; # and abort
} foreach my $FID(@idxs){ if ($self->is_finished_feature($FID)){ # only draft features are allowed to be dragged
$DnD_token->configure(-text => "** select only draft features! **"); $self->{validDnD} = 0; # set a flag so the drop routine knows to immediately abort
return; # and abort
} } $self->{validDnD} = 1; # set a flag so the drop routine knows to immediately abort
$self->_start_DnD_Drag($DnD_token) }, # if we get here, then all is okay!
); # Define a target canvas for drops.
$dest_canvas->DropSite( # this defines the dest_canvas (Finished canvas in this case) as a valid drop site
-droptypes => ['Local'], -dropcommand => [sub {return unless ($self->{validDnD}); $self->{validDnD} = 0; # lower the flag now that we are dropping
$self->_DnD_Drop($source_canvas, $dest_canvas, $DnD_token) } ], -motioncommand => [sub {return unless ($self->{validDnD}); $self->_examine_DnD_Motion($source_canvas, $dest_canvas, $DnD_token) } ], );
}
_start_DnD_DragdescriptionprevnextTop
sub _start_DnD_Drag {
    my($self, $DnD_token) = @_;
    my @idxs = @{$self->getSelectedIDs};  # figure out which widget was clicked on
unless (scalar(@idxs) > 0){ $DnD_token->destroy; # destroy the drag-n-drop process
undef $DnD_token; return; } $DnD_token->configure(-text => ""); # reset the token
my $w = $DnD_token->parent; # $w is the canvas
my $EV = $w->XEvent; # get the mouse event
my $X = $EV->X; my $Y = $EV->Y; # Configure the dnd token to show a helpful message
$DnD_token->configure(-text => "drop in:\n(1) gene - create new transcript\n(2) transcript - add to transcript\n(3) empty space - create new gene"); # Show the token
$DnD_token->MoveToplevelWindow($X, $Y); # the innards of DnD has already converted this label widget into a top-level window, so it is no longer a child of the original canvas
$DnD_token->raise; # make sure it is visible
$DnD_token->deiconify; # and non-iconified
$DnD_token->FindSite($X, $Y, $EV); # call the Drag-n-Drop FindSite subroutine and pass it the coords and the event
# check whether it is currently over a drop-site (note: this call is only executed *once* from this subroutine.
# From now on, a call to FindSite (in DragDrop::rect.pm!!) is made from within the DragDrop module itself
# note also that it is using absolute screen coords to make the determination
# I am not certain, therefore, whether you are able to drop this on a window which is hidden, as I can't see a test for this anywhere.
}
_examine_DnD_MotiondescriptionprevnextTop
sub _examine_DnD_Motion {
	my ($self, $source, $dest, $token) = @_;
    return unless ($token);
    my $EV = $token->XEvent;
    my $abs_x = $EV->X;  # the screen coords of the event
my $abs_y = $EV->Y; my $dest_root_x = $dest->rootx; # the screen coords of the upper left corner of the canvas
my $dest_root_y = $dest->rooty; my $destx = $dest->canvasx($abs_x - $dest_root_x); # the canvas coords of the event, taking into account the scrollregion
my $desty = $dest->canvasy($abs_y - $dest_root_y); if ($self->DropHighlighted){ $self->recolorWithTag("default", "finished", [$self->DropHighlighted]); # set anything highlighted back to default color
$self->DropHighlighted(undef); # and set it to no longer be highlighted
} my $widget =$dest->find('overlapping', $destx, $desty, $destx, $desty); my $FeatureType; # there are two possibilities, either the user is over a blank part of the canvas
# or they are over a widget. Only the latter case is interesting
unless ($widget){$token->configure(-text => "drop here to create new gene"); return}; # we are over an existing widget, but it must be a type that can accept drag and drop
my @tags = $dest->gettags($widget); # get the tags from this widget
my ($FeatureID, $strand, $start, $stop, $offset, $primary_tag); ($FeatureID, $strand, $source, $start, $stop, $offset, $primary_tag) = _extractTags(\@tags); return unless ($FeatureID); # all sorts of things can appear here... so make sure it is a genuine feature
my $SCF = $self->AllFeatures($FeatureID); # get the SeqCanvasFeature for this widget
if ($SCF->Feature->can('transcripts')){$FeatureType = "GENE"} # widget is a gene
elsif ($SCF->Feature->can('exons')){$FeatureType = "TRANSCRIPT"} # widget is a transcript
else {return} # we only allow dropping onto a mapped widget if it is a gene or a transcript
if ($FeatureType eq "GENE"){ $self->recolorWithTag("#99bbee", 'finished', [$FeatureID]); $token->configure(-text => "make new gene transcript"); $self->DropHighlighted($FeatureID); # set this as being currently highlighted
} elsif ($FeatureType eq "TRANSCRIPT"){ $self->recolorWithTag("#eedd07", 'finished', [$FeatureID]); $token->configure(-text => "add to this transcript"); $self->DropHighlighted($FeatureID); # set this as being currently highlighted
}
}
_DnD_DropdescriptionprevnextTop
sub _DnD_Drop {
    my($self, $source, $dest, $token) = @_;

    my $EV = $token->XEvent;
    my $abs_x = $EV->X;  # the screen coords of the event
my $abs_y = $EV->Y; my $dest_root_x = $dest->rootx; # the screen coords of the upper left corner of the canvas
my $dest_root_y = $dest->rooty; my $destx = $dest->canvasx($abs_x - $dest_root_x); # the canvas coords of the event, taking into account the scrollregion
my $desty = $dest->canvasy($abs_y - $dest_root_y); $dest->eventGenerate('<<DROP>>', -when => 'now', -x => $destx, -y => $desty); #==
$self->clearSelections;
}
_bindDropEventdescriptionprevnextTop
sub _bindDropEvent {
	#all we need to do here is ensure that the finished canvas knows what to do when
# a DROP event is triggered... that is, figure out what (if anything) is teh recipient of the drop
# and go on from there.
my ($self) = @_; my $finished = $self->FinishedCanvas; $finished->Tk::bind('<<DROP>>' => sub { my $EV = $finished->XEvent; my $x = $EV->x; my $y = $EV->y; #;;
my $widget = $finished->find('overlapping', $x, $y, $x, $y); if ($widget){ # there is a widget that was dropped on
# deal with it
$self->_receiveDropOnWidget($widget); } else { $self->_receiveDropCreateNewGene(); } });
}
_receiveDropOnWidgetdescriptionprevnextTop
sub _receiveDropOnWidget {
	my ($self, $widget) = @_; # the Canvas WidgetID is sent in here, not the FeatureID... so get the feature
my @tags = $self->FinishedCanvas->gettags($widget); my ($FID) = _extractTags(\@tags); # FeatureID is contained in the tags, and can be parsed out
my $SCF = $self->AllFeatures($FID); # then get this feature id from the list
if ($self->DropHighlighted){ $self->recolorWithTag("default", "finished", [$self->DropHighlighted]); # set anything highlighted back to default color
$self->DropHighlighted(undef); # and set it to no longer be highlighted
} my %features = %{$self->getSelectedFeatures}; my $start = 0; my $stop = 0; my $strand; # get the dimensions of the new transcript
foreach my $feature(values %features){ # get boundary information and ensure they are all on the same strand.
if ($strand && ($strand ne $feature->strand)){ $self->DraftCanvas->Dialog( -title => "cross-strand", -text => "transcript will cross strands - ignored", -default_button => "OK", -buttons => ["OK"])->Show(-global); return 0 } else {$strand = $feature->strand} # get strand information from the current feature while we are at it
} foreach my $feature(values %features){ # sanity check - have to be featues of a certain BioPerl implementing type
next unless $feature; unless ($feature->isa($self->BioPerlFeatureTypes->{Exon}) || $feature->isa($self->BioPerlFeatureTypes->{Poly_A_site}) || $feature->isa($self->BioPerlFeatureTypes->{Promoter}) || $feature->isa($self->BioPerlFeatureTypes->{UTR})){ $self->DraftCanvas->Dialog( -title => "Invalid Feature Type ".(ref $feature)."", -text => "features must be of type Exon, Poly_A_site, Promotor, or UTR. Please re-cast non-compliant features and drop again", -default_button => "OK", -buttons => ["OK"])->Show(-global); return } } if ($SCF->Feature->can('transcripts')){ # it has been dropped on a Gene-type widget, therefore we want to make a new transcript from it
my $Gene = $SCF->Feature; $self->unmapFeatures([$SCF->FID]); $Gene->add_transcript_as_features(values %features); return $self->mapFeatures(undef, [$Gene]); } else{ # in this case we have dropped on something other than a gene-type widget. This will either be a transcript or a transcript part...
my $Trans; my $Gene; # figure out what type of widget it is (this is better done with an ->isa cal I think...)
if ($SCF->Feature->can('exons')){ # is it a transcript?
print "dropping on transcript\n"; $Trans = $SCF->Feature; # this IS the transcript object
$Gene = $SCF->parent_gene; # get the SCF gene object
} elsif ($SCF->Feature->can('cds')){ # is it an exon?, if so we need to findthe transcript of which that exon is a part...
print "dropping on exon\n"; $Trans = $SCF->parent_transcript; # get the parent transcript
$Gene = $SCF->parent_gene; # get the SCF gene object
} else {warn "invalid drop-recipient object"; return 0} print "one\n"; foreach my $feature(values %features){ # ensure they are all on the same strand.
print "two\n"; next unless $feature; print "three\n"; if ($feature->strand ne $Trans->strand){ $self->DraftCanvas->Dialog( -title => "cross-strand", -text => "transcript will cross strands - ignored", -default_button => "OK", -buttons => ["OK"])->Show(-global); return 0} } foreach my $feature(values %features){ print "four ".(ref $feature)."\n"; next unless $feature; if ($feature->isa("Bio::SeqFeature::Gene::ExonI")){print "adding exon $feature ".(ref $feature)."\n";$Trans->add_exon($feature)} elsif ($feature->isa("Bio::SeqFeature::Gene::Poly_A_site")){$Trans->poly_A_site($feature)} elsif ($feature->isa("Bio::SeqFeature::Gene::Promoter")){$Trans->add_promoter($feature)} elsif ($feature->isa("Bio::SeqFeature::Gene::UTR")){$Trans->add_utr($feature)} else { $self->DraftCanvas->Dialog( -title => "Invalid Feature Type ".(ref $feature)."", -text => "features must be of type Exon, Poly_A_site, Promotor, or UTR. Please re-cast non-compliant features and drop again", -default_button => "OK", -buttons => ["OK"])->Show(-global); return } } $self->unmapFeatures([$Gene->FID]); return $self->mapFeatures(undef, [$Gene->Feature]); }
}
_receiveDropCreateNewGenedescriptionprevnextTop
sub _receiveDropCreateNewGene {
	my ($self) = @_;
	my %features = %{$self->getSelectedFeatures};
	my $strand;my $start = 0; my $stop = 0;  # get the dimensions of the new transcript
foreach my $feature(values %features){ next unless $feature; unless ($feature->end < $stop){$stop = $feature->end} unless ($start){$start = $feature->start} if ($start < $feature->start){$start = $feature->start} if ($strand && ($strand ne $feature->strand)){ $self->DraftCanvas->Dialog( -title => "cross-strand", -text => "transcript will cross strands - ignored", -default_button => "OK", -buttons => ["OK"])->Show(-global); if ($self->DropHighlighted){ $self->recolorWithTag("default", "finished", [$self->DropHighlighted]); # set anything highlighted back to default color
$self->DropHighlighted(undef); # and set it to no longer be highlighted
} return 0 } else {$strand = $feature->strand} } foreach my $feature(values %features){ # sanity check - have to be featues of a certain type
next unless $feature; unless ($feature->isa($self->BioPerlFeatureTypes->{Exon}) || $feature->isa($self->BioPerlFeatureTypes->{Poly_A_site}) || $feature->isa($self->BioPerlFeatureTypes->{Promoter}) || $feature->isa($self->BioPerlFeatureTypes->{UTR})){ $self->DraftCanvas->Dialog( -title => "invalid types", -text => "features must be of type Exon, Poly_A_site, Promotor, or UTR. Please re-cast non-compliant features and drop again", -default_button => "OK", -buttons => ["OK"])->Show(-global); if ($self->DropHighlighted){ $self->recolorWithTag("default", "finished", [$self->DropHighlighted]); # set anything highlighted back to default color
$self->DropHighlighted(undef); # and set it to no longer be highlighted
} return } } my $Gene = $self->BioPerlFeatureTypes->{Gene}->new(-start => $start, -end => $stop, -strand => $strand, -primary => "gene", -source => "SeqCanvas"); my $retval=$self->MapSeq->add_SeqFeature($Gene); if (($retval ne "1") && ($retval->isa($self->BioPerlFeatureTypes->{Gene}))) { $Gene=$retval; } $Gene->add_transcript_as_features(values %features); $self->DropHighlighted(undef); return $self->mapFeatures(undef, [$Gene]);
}
_bindMultiSelectiondescriptionprevnextTop
sub _bindMultiSelection {
    my ($self) = @_;
    # the line below converts the x/y coordinates of the event into the canvas coordinates
$self->DraftCanvas->Tk::bind("<ButtonPress-1>" => [ sub { shift; my $x1 = shift; my $y1 = shift; #print "mouse event $x1\n";
$self->dragx1($self->DraftCanvas->canvasx($x1)); $self->dragy1($self->DraftCanvas->canvasy($y1))}, Ev('x'), Ev('y')]); $self->DraftCanvas->Tk::bind("<B1-Motion>" => [sub { $self->{rubberbanding} = "true"; # set a flag to distinguish between ruberbanding and drag/drop
shift; my $tx2 = shift; my $ty2 = shift; # 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 $y2 = $self->DraftCanvas->canvasy($ty2); # delete existing boxse
return unless ($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, -tags => "multi_box"); }, # as parameters send the global x/y coordinates of the event
Ev('x'), Ev('y')] ); $self->DraftCanvas->Tk::bind("<ButtonRelease-1>" => [sub { return unless $self->{rubberbanding}; # this has to distinguish between multi-select and drag/drop
shift; $self->dragx2($self->DraftCanvas->canvasx(shift)); $self->dragy2($self->DraftCanvas->canvasy(shift)); my ($x1, $x2, $y1, $y2) = ($self->dragx1, $self->dragx2, $self->dragy1, $self->dragy2); return unless ($x1 && $x2 && $y1 && $y2); #print "SeqCanvas x1 $x1 y1 $y1 x2 $x2 y2 $y2\n";
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
$self->DraftCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->delete("withtag", "multi_box"); # "
return; } $self->clearSelections; $self->DraftCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->delete("withtag", "multi_box"); $self->DraftCanvas->addtag("group_select", "overlapping", $x1, $y1, $x2, $y2); $self->selectWithTag(["group_select"], 'draft'); $self->DraftCanvas->dtag("all", "group_select"); }, Ev('x'), Ev('y')] ); $self->FinishedCanvas->Tk::bind("<ButtonPress-1>" => [sub { shift; $self->dragx1($self->DraftCanvas->canvasx(shift)); $self->dragy1($self->DraftCanvas->canvasy(shift))}, Ev('x'), Ev('y')]); $self->FinishedCanvas->Tk::bind("<B1-Motion>" => [sub { shift; my $tx2 = shift; my $ty2 = shift; my ($x1, $y1) = ($self->dragx1, $self->dragy1); my $x2 = $self->FinishedCanvas->canvasx($tx2); my $y2 = $self->FinishedCanvas->canvasy($ty2); 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"); }, Ev('x'), Ev('y')] ); $self->FinishedCanvas->Tk::bind("<ButtonRelease-1>" => [sub {shift; $self->dragx2($self->FinishedCanvas->canvasx(shift)), $self->dragy2($self->FinishedCanvas->canvasy(shift)); 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
# delete existing boxes
$self->DraftCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->delete("withtag", "multi_box"); # "
return; } $self->clearSelections; $self->DraftCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->delete("withtag", "multi_box"); $self->FinishedCanvas->addtag("group_select", "overlapping", $x1, $y1,$x2, $y2); $self->selectWithTag(["group_select"], 'finished'); $self->FinishedCanvas->dtag("all", "group_select"); }, Ev('x'), Ev('y')] );
}
_setupAxesdescriptionprevnextTop
sub _setupAxes {
    my ($self)=@_;
    my $draftmap = $self->DraftMap;            # set references to keep code clearer
my $finishedmap = $self->FinishedMap; my $draftc = $self->DraftCanvas; my $finishedc = $self->FinishedCanvas; my $seqlength = $self->MapSeq->length; # Set up axis
$draftmap-> MapAxis('-color' => 'black', '-ticks' => 5000, '-scale' => 1000, -tags => 'axis1', -axis_start => 0); $finishedmap->MapAxis('-color' => 'black', '-ticks' => 5000, '-scale' => 1000, -tags => 'axis1', -axis_start => 0); # else {
# $draftmap-> MapAxis('-color' => 'black', '-ticks' => 1000, '-scale' => 1000,
# -axis_start => 0);
# $finishedmap->MapAxis('-color' => 'black', '-ticks' => 1000, '-scale' => 1000,
# -axis_start => 0);
### AXIS 2
$draftmap-> MapAxis('-ticks' => 2500, '-scale'=> 1000, '-offset' => 9999, '-tags' => 'axis2', -axis_start => 0); $finishedmap->MapAxis('-ticks' => 2500, '-scale'=> 1000, '-offset' => 9999, '-tags' => 'axis2', -axis_start => 0); ### AXIS 3
$draftmap-> MapAxis('-ticks' => 1000, '-scale'=> 1000, '-offset' => 9999, '-tags' => 'axis3', -axis_start => 0); $finishedmap->MapAxis('-ticks' => 1000, '-scale'=> 1000, '-offset' => 9999, '-tags' => 'axis3', -axis_start => 0); ### AXIS 4
$draftmap-> MapAxis('-ticks' => 100, '-scale'=> 1, '-offset' => 9999, '-tags' => 'axis4', -axis_start => 0); $finishedmap->MapAxis('-ticks' => 100, '-scale'=> 1, '-offset' => 9999, '-tags' => 'axis4', -axis_start => 0); # zoom-triggering is an idea from Nomi Harris in her Genotator program
# we changed the structure of the zoom triggers to make them "perlish"
# by putting them in a hash, but the fundamental concept is Nomi's. The idea is that
# several axes are drawn on the canvas with different frequencies of ticks,
# but most are drawn outside of the visible canvas area.
# During the zoom in/out events these "hidden" axes are shifted
# into and out of the visible area (by a canvas->move call)
# note that these axes are **independent objects** relative to the Bio::Tk_Map Axis object.
# i.e. you are not changing the Bio::Tk map axis when you call "move" you are
# simply shifting the position of a line-with-ticks-and-labels object
# that has been given the tag "axis2" or whatever...
my %zoom_triggers = (hin=>{ 0.015 => sub {$draftc ->move('axis1', 0,-9999); $finishedc->move('axis1', 0,-9999); $draftc ->move('axis2', 0, 9999); $finishedc->move('axis2', 0, 9999); }, 0.07 => sub {$draftc ->move('axis3', 0, 9999); $finishedc->move('axis3', 0, 9999); }, 0.5 => sub {$draftc ->move('axis4', 0, 9999); $draftc ->move('axis3', 0,-9999); $draftc ->move('axis2', 0,-9999); $finishedc->move('axis4', 0, 9999); $finishedc->move('axis3', 0,-9999); $finishedc->move('axis2', 0,-9999); }}, hout=>{ 0.015 => sub {$draftc ->move('axis1', 0, 9999); $finishedc->move('axis1', 0, 9999); $draftc ->move('axis2', 0,-9999); $finishedc->move('axis2', 0,-9999); }, 0.07 => sub {$draftc ->move('axis3', 0,-9999); $finishedc->move('axis3', 0,-9999); }, 0.5 => sub {$draftc ->move('axis4', 0,-9999); $draftc ->move('axis3', 0, 9999); $draftc ->move('axis2', 0, 9999); $finishedc->move('axis4', 0,-9999); $finishedc->move('axis3', 0, 9999); $finishedc->move('axis2', 0, 9999); }}, vin=>{ 0.015 => sub {$draftc ->move('axis1', -9999,0); $finishedc->move('axis1', -9999,0); $draftc ->move('axis2', 9999,0); $finishedc->move('axis2', 9999,0); }, 0.07 => sub {$draftc ->move('axis3', 9999,0); $finishedc->move('axis3', 9999,0); }, 0.5 => sub {$draftc ->move('axis4', 9999,0); $draftc ->move('axis3', -9999,0); $draftc ->move('axis2', -9999,0); $finishedc->move('axis4', 9999,0); $finishedc->move('axis3', -9999,0); $finishedc->move('axis2', -9999,0); }}, vout=>{0.015 => sub {$draftc ->move('axis1', 9999,0); $finishedc->move('axis1', 9999,0); $draftc ->move('axis2', -9999,0); $finishedc->move('axis2', -9999,0); }, 0.07 => sub {$draftc ->move('axis3', -9999,0); $finishedc->move('axis3', -9999,0); }, 0.5 => sub {$draftc ->move('axis4', -9999,0); $draftc ->move('axis3', 9999,0); $draftc ->move('axis2', 9999,0); $finishedc->move('axis4', -9999,0); $finishedc->move('axis3', 9999,0); $finishedc->move('axis2', 9999,0); }} ); $self->zoom_triggers(\%zoom_triggers);
}
DoZoomdescriptionprevnextTop
sub DoZoom {
	    # this is also based conceptually on Nomi Harris' Genotator code
# DoZoom provides an extra layer of abstraction above the actual
# zooming, to allow for scale-triggered features.
# we modified the code somewhat, but you will still be able
# to recognize the basic structure of the DoZoom event
# as coded in Genotator.
my ($self)=@_; my ($desired_scale,$zoom_ratio,$min_zoom,$max_zoom, $triggers) = ($self->zoom_level,$self->zoom_ratio, $self->min_zoom, $self->max_zoom, $self->zoom_triggers); my $draftmap = $self->DraftMap; # set up easy references
my $finishedmap = $self->FinishedMap; my $draftc = $self->DraftCanvas; my $finishedc = $self->FinishedCanvas; my ($annotmap); if ($self->AnnotTextMap){$annotmap = $self->AnnotTextMap} my ($pre_scale_factor, $post_scale_factor, $trigger_point, $coderef, $trigger_struct); my $current_loc = $self->current_loc; # the location of the last clicked widget
$draftc->delete('selection_box'); # since boxes don't zoom they have to be deleted
$draftc->dtag('selected'); # along with corresponding "selected" tags
$finishedc->delete('selection_box'); $finishedc->dtag('selected'); $pre_scale_factor = $draftmap->{scale_factor}; # should be the same for both maps... if not, then the whole shebang is buggered!
my $normalized_desired_scale = (($desired_scale/100)**2)*100*$zoom_ratio + $min_zoom;
my $zoom_factor = $normalized_desired_scale/$pre_scale_factor;
# HERE IS WHERE THE AnnotMap::Zoom SUBROUTINE IS CALLED
# ******************************************************
$draftmap->Zoom($zoom_factor, $current_loc); $finishedmap->Zoom($zoom_factor, $current_loc); if ($annotmap) {$annotmap->Zoom($zoom_factor, $current_loc)}; # *****************************************************
my %triggs = %{$triggers}; $post_scale_factor = $draftmap->{scale_factor}; if ($zoom_factor > 1) { # Zoom in
if ($self->{-orientation} eq "horizontal"){ foreach my $scale_threshold (keys %{$triggs{hin}}) { if ($pre_scale_factor < $scale_threshold && $post_scale_factor >= $scale_threshold) { &{$triggs{hin}{$scale_threshold}}; } } } else { foreach my $scale_threshold (keys %{$triggs{vin}}) { if ($pre_scale_factor < $scale_threshold && $post_scale_factor >= $scale_threshold) { &{$triggs{vin}{$scale_threshold}}; } } } } elsif ($zoom_factor < 1) { # Zoom out
if ($self->{-orientation} eq "horizontal"){ foreach my $scale_threshold (keys %{$triggs{hout}}) { if ($post_scale_factor < $scale_threshold && $pre_scale_factor >= $scale_threshold) { &{$triggs{hout}{$scale_threshold}}; } } } else { foreach my $scale_threshold (keys %{$triggs{vout}}) { if ($post_scale_factor < $scale_threshold && $pre_scale_factor >= $scale_threshold) { &{$triggs{vout}{$scale_threshold}}; } } } }
}
_processSeqFeaturesdescriptionprevnextTop
sub _processSeqFeatures {
    # all features should be top_SeqFeatures when they enter this routine...
my ($self, $features) = @_; return unless $features; my @features = @{$features}; $self->_extract_sources(\@features); # this gets the feature and all sub-features, updates SCF's labels and canvas sizes
$self->_extract_transcripts(\@features); # this updates both labels and canvas sizes
}
_check_and_expand_draft_canvasdescriptionprevnextTop
sub _check_and_expand_draft_canvas {
	my ($self,$source) = @_;

    my $canvas = $self->DraftLabelCanvas;
    my $map = $self->DraftCanvas;
	
	foreach my $current_source($self->Sources){
		if ($current_source eq $source){  # if the given source exists, then exit this routine ASAP
if ($self->{-orientation} eq "horizontal"){ #print "\aconfigure scroll ",$self->dyb+1,"\n";
$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
} return; } } # 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; }
}
_extract_transcriptsdescriptionprevnextTop
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) { next unless $feature; my $model=0; # this is a counter for the number of transcript models contained in the gene
next unless ($feature->can("transcripts") || $feature->can("exons") || ($feature->primary_tag eq "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!!)
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"}} $Labels{"transcript$model"} = 1; # define this label as known
} } elsif ($feature->can("exons")){ } else {next} } my @transcripts = (keys %Labels); $self->FinishedSourceLabels(@transcripts); return @transcripts;
}
_check_and_expand_finished_canvasdescriptionprevnextTop
sub _check_and_expand_finished_canvas {
	my ($self, $label) = @_;

    my $canvas = $self->FinishedLabelCanvas;
    my $map = $self->FinishedCanvas;


	foreach my $current_label($self->FinishedSourceLabels){
		if ($current_label eq $label){  # if the given source exists, then set scroll region and exit this routine ASAP
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; } return; } } # 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;
}
_extract_sourcesdescriptionprevnextTop
sub _extract_sources {
	# sources are used to define both offset and color on the draft canvas,
# but only color on the finished canvas
# here we are taking the $feature->source_tag and determining if it has already
# been assigned an offset/color, or if it represents a new source
# if so, then it is assigned an offset/color in the _check_and_expand routines
# then a list of currently valid sources (i.e. those that have color/offset assignments)
# is returned
my ($self, $Features) = @_; # SCFs are SeqCanvasFeatures, which behave like BioPerl Features (~ FeatureI compliant)
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; # add current sources to the hash
} foreach my $Feature(@Features) { next unless $Feature; unless ( ($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;
}
_getAllSubFeaturesdescriptionprevnextTop
sub _getAllSubFeatures {
	my ($self, $feature) = @_;
	my %all_features;
	$all_features{"$feature"} = $feature;  # need a non-redundant list
if ($feature->sub_SeqFeature){ foreach my $sub($feature->sub_SeqFeature){ foreach my $ssub($self->_getAllSubFeatures($sub)){ $all_features{"$ssub"} = $ssub; } $all_features{"$sub"} = $sub; } } return (values %all_features);
}
_drawFinishedLabelsdescriptionprevnextTop
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) { 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->{-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', ); } } 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; }
}
_drawDraftLabelsdescriptionprevnextTop
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
#############################################################################
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) { 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', ); } } if ($self->{-orientation} eq "horizontal"){ #print "\aSCROLL ",$self->dyb+10,"\n";
$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
}
}
_selectFeaturedescriptionprevnextTop
sub _selectFeature {
    # the upshot of this is to identify and box any widgets which are
# "current" on a particular canvas. A widget with the tag
# "now_current" comes from another subroutine which has
# computationally selected this item for whatever reason. The tag
# "current" comes from the Tk canvas itself, and is added to a
# widget when it is clicked by the mouse. We deal with both of
# these situations here. SorM holds 'single' or 'multi', and is
# simply needed to tell the drawSelectionBox routine whether or
# not to delete any existing selection boxes At the end of this
# routine, any "current" and "now_current" widget is given the
# "selected" tag.
my ($self, $canvas, $map, $SorM) = @_; # quickly nab the position that was clicked so that we can zoom around this
my $current_loc; if ($canvas->XEvent){ $current_loc = ($self->{-orientation} eq "horizontal") ? ($canvas->canvasx($canvas->XEvent->x)) : ($canvas->canvasy($canvas->XEvent->y)); } else {$current_loc = 1} $self->current_loc($current_loc); # this becomes the location on the map around which we will zoom if the user choses
my @tags = $canvas->gettags('current'); # get the other tags for the currently selected widget
push @tags, ($canvas->gettags('now_current')); # one or the other of these will return undef under normal circumstances
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
$canvas->delete("sel_box_$FeatureID"); # delete the selection box from around this object only
$canvas->dtag($FeatureID, "selected"); # remove the "selected" status of this widget
$canvas->dtag('now_current'); $exitflag = "true"; # raise the flag to exit this routine
} } return if ($exitflag eq "true"); # get out if the event was a de-selection event
my ($FeatureIndex) = ($FeatureID =~ /^FID(.+)/); 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; # exit as it was not a "real" feature that was selected
} if ($strand eq "-1") { _drawSelectionBox ($self, $canvas, $map, $start, $stop, $offset, $FeatureID, $SorM); } else { _drawSelectionBox ($self, $canvas, $map, $start, $stop, -$offset, $FeatureID, $SorM); } $canvas->addtag("selected", "withtag", "$FeatureID"); #original
$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); }
}
_drawSelectionBoxdescriptionprevnextTop
sub _drawSelectionBox {
		# this is conceptually based on Nomi Harris' Genotator code    my($self, $canvas, $map, $start, $stop, $offset, $FeatureID, $SorM) = @_;
# ******* THIS MUST BE CHANGED ********
my $y1 = $offset -3; #/
my $y2 = $y1 + 6; if ((defined $SorM) && ($SorM eq "single")) {clearSelections($self)}; # if, for example, the user is not holding now the "shift" key when they click
# then clear all other selections/boxes
my @tags = ('selection_box', "sel_box_$FeatureID"); if ($self->{-orientation} eq "vertical"){ $canvas->create('rectangle', # draw a rectangle around the colored feature box widget
$y1, $map->MapLocation($start), $y2, $map->MapLocation($stop), '-tags' =>\@ tags, # add a tag so that we can delete it later if necessary
); } else { $canvas->create('rectangle', # draw a rectangle around the colored feature box widget
$map->MapLocation($start), $y1, $map->MapLocation($stop), $y2, '-tags' =>\@ tags, # add a tag so that we can delete it later if necessary
); }
}
_extractTagsdescriptionprevnextTop
sub _extractTags {
    my (@tagsref) = @_;
    my $tags = shift @tagsref;
    my ($FeatureID, $strand, $source, $start, $stop, $offset, $type);
    foreach my $tag(@{$tags}){
	if ($tag =~ /^(FID.+)/) {$FeatureID = $1}
	if ($tag =~ /^Source (.+)/){$source = $1}
	if ($tag =~ /^Strand (.+)/){$strand = $1}
    if ($tag =~ /^Type (.+)/){$type = $1}
	if ($tag =~ /^_SC_start (.+)/){$start = $1}
    if ($tag =~ /^_SC_stop (.+)/){$stop = $1}
    if ($tag =~ /^_SC_offset (.+)/){$offset = $1}

    }
    return ($FeatureID, $strand, $source, $start, $stop, $offset, $type);
}
_isLabeldescriptionprevnextTop
sub _isLabel {
    my ($self, $widgetTkID, $canvas) = @_;
	my @tags;
	if ($canvas eq "draft"){
		@tags = $self->DraftCanvas->gettags($widgetTkID);
	} else {
		@tags = $self->FinishedCanvas->gettags($widgetTkID);
	}
    foreach my $tag(@tags){
	if ($tag eq "bioTk_Map_Label"){return 1}
    }
    return 0;
}


# *********************************************
# ******************* API STARTS HERE ********
# *********************************************
}
mapFeaturesdescriptionprevnextTop
sub mapFeatures {
    my ($self, $whichmap, $features) = @_;
    my ($map, $canvas, @IDs);
	$self->_processSeqFeatures($features);  # extract/create source/color/offset information
# first map to the draft canvas; all sub features returns the full array of the feature and recursive searches for subfeatures
# i.e. every freakin' thing get's mapped, but there is a filter to get rid of gene-level objects (and CDS spans and such)
foreach my $feature(@{$features}){ next unless $feature; # calls to mapFeatures which take place after initial creation
# of the object may be mapping features which do not yet exist
# on the sequence object. In this case, they need to be added
#to ensure that the SeqObject is always up to date with what is
# being displayed
unless ($feature->entire_seq){$self->MapSeq->add_SeqFeature($feature)} my @sub_features = $self->_getAllSubFeatures($feature); # okay, rip it apart and start mapping it
push @IDs, ($self->_mapOntoDraft(\@sub_features)); # @IDs is a list of FIDxxx for the features that have been mapped
} # this is a searchable tag for that feature
# now map any gene-objects and their transcripts;
# *only* objects with the primary_tag "gene", or which ->can('transcripts') are mapped
# this we only get things that we explicitly say are genes, or things that fulfill
# the GeneStructureI limits
# sub objects, such as transcripts and exons, are handled delicately
push @IDs, ($self->_mapOntoFinished($features)); # takes an array ref of top-level objects
return\@ IDs; # return the list of FIDxxx to the caller in case they want to know...
}
_mapOntoFinisheddescriptionprevnextTop
sub _mapOntoFinished {
	my ($self, $genes)=@_;
    my @MappedIDs;

    foreach my $gene(@{$genes}) {
        next unless ($gene->can("transcripts") || ($gene->primary_tag eq "gene"));  # all ::Gene::GeneStructureI objects should have this method, ignore them if they don't
my $SCF = Bio::Tk::SeqCanvasFeature->new( SeqCanvas => $self, Feature => $gene, # this fills all of the FeatureI methods
canvas_name => 'finished', canvas => $self->FinishedCanvas, map => $self->FinishedMap, label => $self->label, ); # create a new SeqcanvasFeature object for this feature
# it is assigned an FID during creation
my ($genes, $transcripts, $exons, $promotors, $polyAs) = $SCF->drawThyself; # ask it to draw itself on whichever map it is supposed to
# note that the line above begins a complex process of drawing the gene and
# all of its transcripts, and their sub-objects
# their SCF's are returned here in the order above
# these must be bound to respond to various mouse events
# and must then be added to the global list of mapped features
# ******* EDIT BINDING FOR DIFFERENT THINGS
# we might want them to respond to the mouse differently, so they are dealt with separately
foreach my $gene(@{$genes}){ $self->_setupGeneBindings($gene->FID); } foreach my $transcript(@{$transcripts}){ # this is the critical one... it has to respond to drag/drop events
$self->_setupTranscriptBindings($transcript->FID); } foreach my $exon(@{$exons}){ $self->_setupExonBindings($exon->FID); } foreach my $promotor(@{$promotors}){ $self->_setupPromotorBindings($promotor->FID); } foreach my $polyA(@{$polyAs}){ $self->_setupPolyABindings($polyA->FID); } foreach $SCF(@{$genes},@{$transcripts},@{$exons},@{$exons},@{$promotors},@{$polyAs}){ $self->AllFeatures($SCF->FID, $SCF); # record the existence of each widget
push @MappedIDs, $SCF->FID; # get the mapped ID's
} } # end of the foreach $gene loop
return @MappedIDs;
}
_setupGeneBindingsdescriptionprevnextTop
sub _setupGeneBindings {
	my ($self, $FID) = @_;
	my $canvas = $self->FinishedCanvas;
	my $map = $self->FinishedMap;																			
	$canvas->bind("$FID", '<Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')});       # clicking the left mouse selects a single widget
$canvas->bind("$FID", '<Shift-Button-1>', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets
$canvas->bind("$FID", '<Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only
$canvas->bind("$FID", '<Shift-Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases
$canvas->bind("$FID", '<Enter>', 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", '<Leave>', sub{$canvas->dtag("Mouse_over")}); # The latter two bindigns can be examined via a call to $SeqCanvas->selectWithtag("mouse_over")<Movement> event in the
# top-level windowing system
}
_setupTranscriptBindingsdescriptionprevnextTop
sub _setupTranscriptBindings {
	my ($self, $FID) = @_;
	my $canvas = $self->FinishedCanvas;
	my $map = $self->FinishedMap;																			
	$canvas->bind("$FID", '<Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')});       # clicking the left mouse selects a single widget
$canvas->bind("$FID", '<Shift-Button-1>', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets
$canvas->bind("$FID", '<Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only
$canvas->bind("$FID", '<Shift-Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases
$canvas->bind("$FID", '<Enter>', 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", '<Leave>', sub{$canvas->dtag("Mouse_over")}); # The latter two bindigns can be examined via a call to $SeqCanvas->selectWithtag("mouse_over")<Movement> event in the
# top-level windowing system
}
_setupExonBindingsdescriptionprevnextTop
sub _setupExonBindings {
	my ($self, $FID) = @_;
	my $canvas = $self->FinishedCanvas;
	my $map = $self->FinishedMap;																			
	$canvas->bind("$FID", '<Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')});       # clicking the left mouse selects a single widget
$canvas->bind("$FID", '<Shift-Button-1>', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets
$canvas->bind("$FID", '<Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only
$canvas->bind("$FID", '<Shift-Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases
$canvas->bind("$FID", '<Enter>', 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", '<Leave>', sub{$canvas->dtag("Mouse_over")}); # The latter two bindigns can be examined via a call to $SeqCanvas->selectWithtag("mouse_over")<Movement> event in the
# top-level windowing system
}
_setupPromotorBindingsdescriptionprevnextTop
sub _setupPromotorBindings {
	my ($self, $FID) = @_;
	my $canvas = $self->FinishedCanvas;
	my $map = $self->FinishedMap;																			
	$canvas->bind("$FID", '<Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')});       # clicking the left mouse selects a single widget
$canvas->bind("$FID", '<Shift-Button-1>', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets
$canvas->bind("$FID", '<Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only
$canvas->bind("$FID", '<Shift-Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases
$canvas->bind("$FID", '<Enter>', 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", '<Leave>', sub{$canvas->dtag("Mouse_over")}); # The latter two bindigns can be examined via a call to $SeqCanvas->selectWithtag("mouse_over")<Movement> event in the
# top-level windowing system
}
_setupPolyABindingsdescriptionprevnextTop
sub _setupPolyABindings {
	my ($self, $FID) = @_;
	my $canvas = $self->FinishedCanvas;
	my $map = $self->FinishedMap;																			
	$canvas->bind("$FID", '<Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')});       # clicking the left mouse selects a single widget
$canvas->bind("$FID", '<Shift-Button-1>', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets
$canvas->bind("$FID", '<Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only
$canvas->bind("$FID", '<Shift-Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases
$canvas->bind("$FID", '<Enter>', 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", '<Leave>', sub{$canvas->dtag("Mouse_over")}); # The latter two bindigns can be examined via a call to $SeqCanvas->selectWithtag("mouse_over")<Movement> event in the
# top-level windowing system
}
_setupDraftBindingsdescriptionprevnextTop
sub _setupDraftBindings {
	my ($self, $FID) = @_;
	my $canvas = $self->DraftCanvas;
	my $map = $self->DraftMap;																			
	
	$canvas->bind("$FID", '<Button-1>',        sub{_selectFeature($self, $canvas, $map, 'single')});       # clicking the left mouse selects a single widget
$canvas->bind("$FID", '<Shift-Button-1>', sub{_selectFeature($self, $canvas, $map, 'multi')}); # shift-clicking selects multiple widgets
$canvas->bind("$FID", '<Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # a double-click must be assigned to only
$canvas->bind("$FID", '<Shift-Double-Button-1>', sub{_selectFeature($self, $canvas, $map, 'single')}); # one widget, so call with 'single' for both cases
$canvas->bind("$FID", '<Enter>', 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", '<Leave>', sub{$canvas->dtag("Mouse_over")}); # The latter two bindigns can be examined via a call to $SeqCanvas->selectWithtag("mouse_over")<Movement> event in the
# top-level windowing system
}
_mapOntoDraftdescriptionprevnextTop
sub _mapOntoDraft {
	my ($self, $features)=@_;
    my @MappedIDs;
    foreach my $feature(@{$features}) {
		next unless $feature;

    ######### FILTER CRAP ################
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"); # this had to be removed because embl doesn't have "gene" objects per se, only CDS's that are associated with a gene
next if ($feature->primary_tag eq "gene"); next if ($feature->primary_tag eq "mRNA"); 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)
######## END OF FILTER ##############
#print "mapping onto draft ",$feature->id, " start ",$feature->start,"\n";
# create a SeqCanvasFeature object - acts, looks, and smells like a FeatureI object, with a bit of extra knowledge about itself
my $SCF = Bio::Tk::SeqCanvasFeature->new( SeqCanvas => $self, Feature => $feature, # this fills all of the FeatureI methods
canvas_name => 'draft', canvas => $self->DraftCanvas, map => $self->DraftMap, offset => $self->current_offsets->{$feature->source_tag}, color => $self->current_colors->{$feature->source_tag}, label => $self->label, ); # create a new SeqcanvasFeature object for this feature
$self->AllFeatures($SCF->FID, $SCF); # stick this into the local encapsulated hash of all features
$SCF->drawThyself; # ask it to draw itself on whichever map it is supposed to
$self->_setupDraftBindings($SCF->FID);# since this is a single, simple object,we can bind events to its FIDxxx
push @MappedIDs, $SCF->FID; # get the mapped ID's
} # end of the foreach $feature loop
return @MappedIDs; # return them to the mapFeatures call
}
deleteFeaturesdescriptionprevnextTop
sub deleteFeatures {
    my ($self, $FeatureIDs) = @_;
    return unless $self->MapSeq->isa('Bio::UpdateableSeqI');
    foreach my $FeatureID (@$FeatureIDs){
    	my $SCF = $self->AllFeatures($FeatureID); 		# get the SCF (SeqCanvasFeature) object
next unless $SCF; my $transcriptobj=$SCF->parent_transcript; my $geneobj=$SCF->parent_gene; my $transcript=$transcriptobj ? $transcriptobj->Feature : undef; my $gene=$geneobj ? $geneobj->Feature : undef; if ($gene) { my $unmapped=$self->unmapFeatures([$geneobj->FID]); return unless $unmapped; my $remapped=$self->MapSeq->delete_feature($SCF->Feature,$transcript,$gene); #this needs to be implemented in Bio::Seq
$self->mapFeatures(undef,[$gene]) if $gene->entire_seq; #only remap if the gene still exists
$self->mapFeatures(undef,$remapped) if $remapped && @$remapped; } else { my $unmapped=$self->unmapFeatures([$FeatureID]); my $remapped=$self->MapSeq->delete_feature($SCF->Feature,$transcript,$gene); #this needs to be implemented in Bio::Seq
if (defined $remapped) { $self->mapFeatures(undef,$remapped) if @$remapped; } else { #unsuccessful deletion
$self->mapFeatures(undef,[$SCF->Feature]); #then remap the not deleted feature
} } }
}
unmapFeaturesdescriptionprevnextTop
sub unmapFeatures {
    my ($self, $FeatureIDs) = @_;
    my @FeatureIDs = @{$FeatureIDs};
    my (@unmappedFeatures);
    if ($#FeatureIDs == -1) {return\@ unmappedFeatures};

    $self->DraftCanvas->toplevel->Busy;
    $self->clearSelections;
    foreach my $FeatureID (@FeatureIDs){
    	my $SCF = $self->AllFeatures($FeatureID); 		# get the SCF (SeqCanvasFeature) object
next unless $SCF; my $unmappedFeature = $SCF->Feature; # retrieve the BioPerl Feature object
my (%SubFeatureList,@Sortedlist); foreach ($self->_getAllSubFeatures($unmappedFeature)) { $SubFeatureList{$_}=$_; } foreach my $typevar (qw(Gene Transcript)) { #we are going to sort these features into bins
foreach (keys %SubFeatureList) { if ($SubFeatureList{$_}->isa($self->BioPerlFeatureTypes->{$typevar})) { #genes first, then transcripts
push @Sortedlist,$SubFeatureList{$_}; delete $SubFeatureList{$_}; } } } push @Sortedlist, values %SubFeatureList; #Whatever is left goes in at the end
foreach my $subfeature (reverse @Sortedlist) { # now get any and all subfeatures and unmap them
foreach my $SCF ($self->translateFeatureIntoSCF($subfeature)) { # we need the FID to delete it, so retrieve all the SCFs for that feature
next unless $SCF; $self->DraftCanvas->delete($SCF->FID); # delete the widgets by their ID
$self->FinishedCanvas->delete($SCF->FID); push @unmappedFeatures, $SCF->Feature;# get the feature
$self->AllFeatures($SCF->FID, undef); # and remove it from the feature list
} } } $self->DraftCanvas->toplevel->Unbusy; return\@ unmappedFeatures
}
translateFeatureIntoSCFdescriptionprevnextTop
sub translateFeatureIntoSCF {
	# you send this a BioPerl feature object, and it will return  you
# the SCF reference corresponding to that feature,
# presuming that a SeqCanvasFeature already *exists* for that Feature object
# else returns undef
my ($self, $feature) = @_; my @SCF; my $x = scalar $feature; # convert incoming feature to a scalar
while (my ($FID, $SCF) = each %{$self->AllFeatures}){ # iterate through the known feature hash
my $y = scalar $SCF->Feature; # make a scalar from each feature
if ($x eq $y){ push @SCF, $SCF; } } return @SCF;
}
getSelectedIDsdescriptionprevnextTop
sub getSelectedIDs {
	
	# a special case of getIDsWithTag - just fill in with "selected" and return the result
my $self = shift; my $FeatureListRef = $self->getIDsWithTag(["selected"]); return $FeatureListRef;
}
getSelectedTagsdescriptionprevnextTop
sub getSelectedTags {
    my $self = shift;
    my $Dcanvas = $self->DraftCanvas;
    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"); # 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
} 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} if ($tag =~ /^Source (.+)/){$source = $1} if ($tag =~ /^Strand (.+)/){$strand = $1} if ($tag =~ /^Type (.+)/){$type = $1} if ($tag =~ /Canvas (.+)/){$canvas = $1} if ($tag =~ /^DB_ID (.+)/){$DB_ID = $1} } return ($FeatureID, $strand, $source, $type, $canvas, $DB_ID); # note that this returns only the values for the last-parsed widget!!
}
getIDsWithTagdescriptionprevnextTop
sub getIDsWithTag {
	my ($self, $whichtags) = @_;
	my @whichtags = @{$whichtags};	
	my $Dcanvas = $self->DraftCanvas;
	my $Fcanvas = $self->FinishedCanvas;
	my (@FeatureIDList, @selected);
	
	if ($#whichtags == -1) {return\@ FeatureIDList};           # returns the empty list if no parameters were sent into the routine
foreach my $whichtag(@whichtags){ #first check the Draft canvas for selected
@selected = $Dcanvas->find("withtag", $whichtag); # find all Widget ID's that have a "selected" tag
foreach my $widget(@selected){ my @tags = $Dcanvas->gettags($widget); # for each widget, extract all tags associated with that widget
my ($FeatureID, $strand, $source) = _extractTags(\@tags); # get just the interesting ones
next if (!$FeatureID); my $testflag = 0; # this test routine is the result of a two-hour-long god damn frustrating bug-hunt!
foreach my $testID(@FeatureIDList){ # It turns out that when you click on a labelled widget BOTH the widget AND
if ($testID eq $FeatureID){$testflag = 1; last} # the label are considered "selected" as two independant widgets with the same
} # FID number coming from Bio::TkPerl, but different Tk Canvas widget ID's... bastards!
if ($testflag == 0){push @FeatureIDList, $FeatureID}; # so to prevent errors elsewhere, stick the ID in the list to be returned to the user
} # iffff that ID is unique to the list (i.e. is not the label for an already pushed widget)
# now do the Finished Canvas
@selected = $Fcanvas->find("withtag", $whichtag); foreach my $widget(@selected){ my @tags = $Fcanvas->gettags($widget); my ($FeatureID, $strand, $source) = _extractTags(\@tags); # stick the id in the list
next if (!$FeatureID); my $testflag = 0; foreach my $testID(@FeatureIDList){ if ($testID eq $FeatureID){$testflag = "1"; last} } if ($testflag == 0){push @FeatureIDList, $FeatureID}; } } # end of foreach $whichtag
return\@ FeatureIDList;
}
getSelectedFeaturesdescriptionprevnextTop
sub getSelectedFeatures {
	# this is a special case of getFeaturesWithTag
# so fill in the "whichtag" with "selected" and return the result
my $self = shift; my $FeatureHashRef = $self->getFeaturesWithTag(["selected"]); return $FeatureHashRef;
}
getFeaturesWithTagdescriptionprevnextTop
sub getFeaturesWithTag {
	my ($self, $whichtags) = @_;
	my @whichtags = @{$whichtags};
	
	my (%FeatureHash, @selected);
	if ($#whichtags == -1){return\% FeatureHash};   # returns an empty hash if there were no parameters sent
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
foreach my $widget(@selected){ my @tags = $Dcanvas->gettags($widget); # for each widget, extract all tags associated with that widget
my ($FeatureID, $strand, $source) = _extractTags(\@tags); # get just the interesting ones
next if (!$FeatureID); my $SCF = $self->AllFeatures($FeatureID); # extract this SeqCanvasFeature object from the indexed list
my $feature = $SCF->Feature; # retrieve the Feature object from that
$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){ my @tags = $Fcanvas->gettags($widget); my ($FeatureID, $strand, $source) = _extractTags(\@tags); next if (!$FeatureID); my $SCF = $self->AllFeatures($FeatureID); # extract this SeqCanvasFeature object from the indexed list
my $feature = $SCF->Feature; # retrieve the Feature object from that
$FeatureHash{$FeatureID} = $feature; # assign it in a $hash{FIDxxx} = $FeatureObject
} # N.B. because of the hash structure we don't need to worry about this feature/label duplication
} # end of foreach $whichtag # that arose in getIDsWithTag, as it simply overwrites them.
return\% FeatureHash; # return the hash
}
clearSelectionsdescriptionprevnextTop
sub clearSelections {
	my $self = shift;
    $self->DraftCanvas->delete('selection_box');   #  we delete all reference to selected stuff on both maps
$self->DraftCanvas->dtag('selected'); # "
$self->FinishedCanvas->delete('selection_box');# "
$self->FinishedCanvas->dtag('selected'); # "
}
selectFeaturesdescriptionprevnextTop
sub selectFeatures {
	my $self = shift @_;
	my @FeatureIDs = @{shift @_};
	return if ($#FeatureIDs == -1);
	
	foreach my $FeatureID(@FeatureIDs) {
		$self->DraftCanvas->addtag('now_current', 'withtag', $FeatureID);    		# the _selectFeature routine looks for widgets that are 'current' and boxes them
_selectFeature ($self, $self->DraftCanvas, $self->DraftMap, 'multi'); # call the routine in multi-mode
$self->FinishedCanvas->addtag('now_current', 'withtag', $FeatureID); # the _selectFeature routine looks for widgets that are 'current' and boxes them
_selectFeature ($self, $self->FinishedCanvas, $self->FinishedMap, 'multi'); # call the routine in multi-mode
}
}
selectWithTagdescriptionprevnextTop
sub selectWithTag {
		my $self = shift @_;
	my @tags = @{shift @_};
	my $whichmap = shift @_;
	return if ($#tags == -1);
	
	foreach my $tag(@tags) {
		if (defined $whichmap && $whichmap eq 'finished'){
    		my @widgets = $self->FinishedCanvas->find("withtag", $tag);
    		foreach my $widget(@widgets){
    			$self->FinishedCanvas->addtag('now_current', 'withtag', $widget);    		# the _selectFeature routine looks for widgets that are 'now_current' and boxes them
_selectFeature ($self, $self->FinishedCanvas, $self->FinishedMap, 'multi'); # call the routine in multi-mode
} } elsif (defined $whichmap && $whichmap eq 'draft'){ my @widgets = $self->DraftCanvas->find("withtag", $tag); foreach my $widget(@widgets){ if (! $self->_isLabel($widget, 'draft')){ $self->DraftCanvas->addtag('now_current', 'withtag', $widget); # the _selectFeature routine looks for widgets that are 'now_current' and boxes them
_selectFeature ($self, $self->DraftCanvas, $self->DraftMap, 'multi'); # call the routine in multi-mode
} } } else { my @widgets = $self->FinishedCanvas->find("withtag", $tag); push @widgets, $self->DraftCanvas->find("withtag", $tag); foreach my $widget(@widgets){ if (! $self->_isLabel($widget, 'finished')){ $self->FinishedCanvas->addtag('now_current', 'withtag', $widget); # the _selectFeature routine looks for widgets that are 'now_current' and boxes them
_selectFeature ($self, $self->FinishedCanvas, $self->FinishedMap, 'multi'); # call the routine in multi-mode
$self->DraftCanvas->addtag('now_current', 'withtag', $widget); # the _selectFeature routine looks for widgets that are 'now_current' and boxes them
_selectFeature ($self, $self->DraftCanvas, $self->DraftMap, 'multi'); # call the routine in multi-mode
} } } }
}
recolorWithTagdescriptionprevnextTop
sub recolorWithTag {
    my ($self, $color, $whichmap, $tagsref) = @_;
    my @tags = @{$tagsref};
    return if ($#tags == -1);
    if ($whichmap eq 'draft'){
    	foreach my $tag(@tags) {
	    if ($color eq "default"){
			my @thesetags = $self->DraftCanvas->gettags($tag); # extract tags
# specifially to obtain 'source'
my ($ID, $strand, $source) = _extractTags(\@thesetags); # get the color associated with 'source'
next unless $ID; my $thiscolor = $self->current_colors->{$source}; if ($thiscolor){ # assign that color to the widget
$self->DraftCanvas->itemconfigure($tag, -fill => $thiscolor); } else { # this must be a gene or transcript type feature because all other features have a color associated with their source tags...
# of course... no gene type features should ever appear on the draft canvas... so...??? what the hell :-)
my $SCF = $self->AllFeatures($ID); # get the scf
return unless $SCF; if ($SCF->Feature->can("transcripts")){ # then it is a gene
my $thiscolor = $self->current_colors->{"gene"}; $self->DraftedCanvas->itemconfigure($tag, -fill => $thiscolor); } elsif ($SCF->Feature->can("exons")){ # then it is a transcript
my $thiscolor = $SCF->transcript_color; # what color are transcripts in this SCF?
$self->DraftCanvas->itemconfigure($tag, -fill => $thiscolor); } } } else { # assign that color to the widget
$self->DraftCanvas->itemconfigure($tag, -fill => $color); } } } elsif ($whichmap eq 'finished') { foreach my $tag(@tags) { if ($color eq "default"){ # extract tags
my @thesetags = $self->FinishedCanvas->gettags($tag); # specifially to obtain 'source'
my ($ID, $strand, $source) = _extractTags(\@thesetags); # get the color associated with 'source
next unless $ID; my $thiscolor = $self->current_colors->{$source}; if ($thiscolor){ # assign that color to the widget
$self->FinishedCanvas->itemconfigure($tag, -fill => $thiscolor); } else { # this must be a gene or transcript type feature because all other features have a color associated with their source tags...
# of course... no gene type features should ever appear on the draft canvas... so...??? what the hell :-)
my $SCF = $self->AllFeatures($ID); # get the scf
return unless $SCF; if ($SCF->Feature->can("transcripts")){ # then it is a gene
my $thiscolor = $self->current_colors->{"gene"}; $self->FinishedCanvas->itemconfigure($tag, -fill => $thiscolor); } elsif ($SCF->Feature->can("exons")){ # then it is a transcript
my $thiscolor = $SCF->transcript_color; # what color are transcripts in this SCF?
$self->FinishedCanvas->itemconfigure($tag, -fill => $thiscolor); } } } else { # assign that color to the widget
$self->FinishedCanvas->itemconfigure($tag, -fill => $color); } } } else { print "No known map-type was specified in the call to Recolor", " - must be either 'draft' or 'finished'"; }
}
assignCustomColorsdescriptionprevnextTop
sub assignCustomColors {
    my ($self, $top) = @_;
    return if (!$top);
    return if (!ref($top) =~ /MainWindow/);
    my ($FID, $strand, $source, $type, $canvas, $DB_ID) = $self->getSelectedTags;
    return if (!$source);
    my $cedit;
    $cedit = $top->ColorEditor(-title => "chose a new color for the $source features",
			       -command =>
			       sub {
				   my $color = $_[1];
				   $self->current_colors->{$source} = $color;
				
				   $self->recolorWithTag('default', 'draft', ["Source $source"]);
				   $self->recolorWithTag('default', 'finished', ["Source $source"]);
				   $cedit->destroy;
			       } );

$cedit->delete_menu_item(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 16, 17);
$cedit->Show;
$cedit->add_menu_item($source);
}
is_draft_featuredescriptionprevnextTop
sub is_draft_feature {
  # this simply returns 1 (true) or undef (false) if the passed widgetID is on the draft map	my ($MapObj, $FID) = @_;
return if (!$FID); my $result; my @WidgetTags = $MapObj->DraftCanvas->gettags("$FID"); if (@WidgetTags){$result = 1} return $result;
}
is_finished_featuredescriptionprevnextTop
sub is_finished_feature {
    my ($MapObj, $FID) = @_;
    return if (!$FID);
    my $result;
    my @WidgetTags = $MapObj->FinishedCanvas->gettags("$FID");
    if (@WidgetTags){$result = 1}
    return $result;
}
General documentation
AUTHORSTop
Mark Wilkinson (mwilkinson@gene.pbi.nrc.ca),
David Block (dblock@gnf.org)
ACKNOWLEDGEMENTSTop
This module requires an updated version of Gregg Helt's original
BioTkPerl modules (version 0.82) which are available from BioPerl. The
original BioTkPerl (version 0.80) is Copyright (c) Gregg Helt, 1995;
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)
DISCLAIMERTop
Anyone who intends to use and uses this software and code acknowledges and
agrees to the following: The National Research Council of Canada (herein "NRC")
disclaims any warranties, expressed, implied, or statutory, of any kind or
nature with respect to the software, including without limitation any warranty
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.
NEW FEATURES IN THIS VERSIONTop
Re-casting of SeqFeature typesTop
During editing you may map numerous features of the type SeqFeature::Generic
or other non-GeneStructureI compliant feature type. Since the Finished canvas
accepts only GeneStructureI objects, it is now possible to "re-cast"
features on the draft canvas into any of the GeneStructureI features types (Exon,
Intron, UTR, PolyA, Promoter, NC_Feature). This is accomplished by selecting the
features you wish to be re-cast, right-mouse-clicking on the canvas, and selecting
the new cast from the drop-down menu. Internally a new object of the selected type is
created from the GFF2 string of the original feature. This is added to the Seq object,
the original object is deleted from the Seq object, the old widget unmapped and the new
widget mapped. (Note: each widget has a unique WidgetID, but may point to the same
underlying feature. Thus in the case of multiple transcripts, the same SeqFeature object
may be represented by multiple Widgets with unique WidgetID's)
Live Sequence Object Editing and RetrievalTop
All events happening on the canvas are fed back through to the SequenceI object
that was used to initialize the SeqCanvas. Thus at any given moment the Seq object
can be retrieved using:
   $SeqObj = $SeqCanvas->MapSeq;
and the structure of the object you obtain is precisely (I believe) what is currently visible
on the canvas. Thus, if you should ever wish to do so, SeqCanvas could be used as
a 'sanity checkpoint' in a pipeline, where an annotator can view the data, make
any obvious modifications, and then send it farther along the pipe. N.B. I haven't
tested this thoroughly, so don't take it as gospel until you have done this a few
times.
Drag-n-Drop editingTop
This version of SeqCanvas supports drag-n-drop for the creation of:
    *(1)
    New genes
    *(2)
    New gene transcripts
    *(3)
    addition of features to existing transcripts
The interface is straightforward - simply select one or more features on the Draft canvas
and drag them onto the Finished canvas. If you drag them to an empty spot, you will create
a new gene. If you drag them onto an existing gene, you will create a new transcript for that
gene. If you drag them onto an existing transcript you will add them to that transcript.
WIDGET TAGSTop
Each map-widget has several "reliable" tags attached to it. These tags
are FIDxxxx, Source and Strand, Type, and Canvas, where:
    *(1)
    FIDxxxx is the unique identifier for that particular map-widget over all maps (even in multiple windows)
    *(2)
    Source is derived from the "source" tag of the SeqFeature object this widget represents
    *(3)
    Strand is derived from the "strand" tag of the SeqFeature object, converted into the GFF standard of +/-/. to represent the three possible strand values.
    *(4)
    Type isthe feature type, derived from the primary_tag of the SeqFeature object
    *(5)
    Map is either 'draft' or 'finished' to represent an object on the white or blue maps respectively
So for example, a map widget might have the tags :
	FID22354 (no space)
Source GeneMarkHMM (single space separated)
Strand + (single space separated)
Type exon ( " )
Canvas draft ( " )
If your BioSeq Features are being derived from an external database,
it is possible to also include the unique index number of that
database entry as a fourth tag on the associated map-widget. To do so,
create your SeqFeature objects with an additional tag "id", where the
unique databse index number is the value of this tag. This index
number is then attached to the widget as a fourth tag with the form:
	DB_ID xxxxx (x's represent the unique index value)
The values of these three/four tags can be retrieved for any selected
object using the getSelectedTags function (see below) in order to
relate mapped objects back to their original database entries. Using
the selectWithTag or recolorWithTag routines (see below) requires that
you pass the **full tag** as the desired selection (eg. pass "Source
GeneMarkHMM" not just "GeneMarkHMM")
CODE EXAMPLES: Adding/Binding FeaturesTop
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 use Bio::SeqFeature::Gene::Exon; use Bio::SeqFeature::Gene::Transcript; use Bio::SeqFeature::Gene::GeneStructure; use Bio::SeqFeature::Generic; my $exon1 = new Bio::SeqFeature::Gene::Exon (-start => 3300, -end => 4000, -primary => "exon", -source => "genscan", -strand => -1); my $exon2 = new Bio::SeqFeature::Gene::Exon (-start => 4400, -end => 6000, -primary => "exon", -source => "genscan", -strand => -1); my $exon3 = new Bio::SeqFeature::Gene::Exon (-start => 3000, -end => 4000, -primary => "exon", -source => "genemark", -strand => -1); my $exon4 = new Bio::SeqFeature::Gene::Exon (-start => 5000, -end => 6000, -primary => "exon", -source => "genemark", -strand => -1); my $polyA = Bio::SeqFeature::Generic->new(-start => 2500, -end => 2800, -primary=> "polyA", -source => "polyA-scan", -strand => -1); my $prom = Bio::SeqFeature::Generic->new(-start => 6200, -end => 6500, -primary=> "promoter", -source => "prom-find", -strand => -1); my $transcript = Bio::SeqFeature::Gene::Transcript->new(-start => 2500, -end => 6500, -primary => "transcript", -source => "transcript", -strand => -1); my $transcript2 = Bio::SeqFeature::Gene::Transcript->new(-start => 2500, -end => 6500, -primary => "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 => "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"} }); # one useful binding would be to retrieve the current Seq object # after an editing session. The code below binds the "n" key # to retrieve the Seq object from the current SeqCanvas window and create a # new SeqCanvas window with it. $MW->bind("" => sub { 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'); my $axis_length = 800; # how large I want the final map to be my $MapObj2 = Bio::Tk::SeqCanvas->new( $axis_length, $Frame, $lblSysMess, $MapObj->MapSeq, # Here we are getting the up-to-date Seq object -orientation => 'horizontal', label => 'author', width => 300, ); });
MethodsTop
MenuTop
 Title    : Menu
Usage : $menu = $MapObj->Menu()
Function : Allow editing of the drop-down menu
Returns : returns a reference to the drop-down menu object (right-click)
Args :
ReCastMenuTop
 Title    : ReCastMenu
Usage : $menu = $MapObj->ReCastMenu()
Function : Allow editing of the cascadeing "reCast As" menu
Would be useful to re-define the callbacks associated
with a re-casting event.
Returns : returns a reference to the menu object
Args :
EVENTSTop
The SeqCanvas both internally responds to mouse events, and sets
"tags" on the mapped feature in response to mouse events such that the
user can "trap" these events in the top-level windowing system and
evaluate which mapped feature the user was manupulating.
Mouse-ClickTop
Clicking or shift-Clicking the left mouse button over a mapped feature
causes the feature(s) to become "selected". A selected object is
displayed on the screen with a black box surrounding the object, and
the object becomes tagged with a testable tag "selected" (use the
getSelectedFeatures or getSelectedIDs to retrieve additional
information about this object)
Mouse-Double-ClickTop
Both Double-clicking and Shift Double-Clicking
the mouse over an object selects that (single) mapped feature. All
other features become unselected.
Mouse-Click and DragTop
Used to select multiple objects. Any object touched by the bounding
box will be included in the selection.
Mouse-OverTop
As the mouse pointer enters the mapped widget, the tag "Mouse_over" is
added to this object. information about this object could be retrieved
by, for example, calling the getIDsWithTag(["Mouse_over"])
method. This tag is removed when the mouse pointer leaves the
mapped-feature space. Bind the Movement event in the top-level
windowing system to track the mouse movements if you wish to monitor
the Mouse-Over widget events.