Bio::Tk bioTk_Map
Package variablesGeneral documentationMethods
Toolbar
WebCvs
Package variables
No package variables defined.
Included modules
Bio::Tk::bioTk_Utilities qw ( bioTk_ParseArgs )
Synopsis
No synopsis!
Description
No description!
Methods
new
No description
Code
MapAxis
No description
Code
MapObject
No description
Code
MapObjectLabel
No description
Code
MapReset
No description
Code
MapPosition
No description
Code
MapLocation
No description
Code
MapBrokenLine
No description
Code
MapTriangle
No description
Code
MapDiamond
No description
Code
MapOval
No description
Code
MapRectangle
No description
Code
MapSimpleLine
No description
Code
MapSpliceLine
No description
Code
MapRangeBars
No description
Code
prMapObjects
No description
Code
prMapObject
No description
Code
MapInsertApart
No description
Code
Methods description
None available.
Methods code
newdescriptionprevnextTop
sub new {
     my $package = shift;
    my $class   = $package;
    $class =~ s/^Bio::Tk:://;
    my $parent = shift;
    my $self = {};

    $self->{canvas} = $parent;   # will have to go through this to draw...
my($xa, $ya, $xz, $yz, $range, $axis_loc); my($map_start, $map_end, $canvas_start, $canvas_end, $map_range, $canvas_range, $scale_factor, $canvas_min, $canvas_max); $xa = shift; $ya = shift; $xz = shift; $yz = shift; my @args = @_; my %ivars = ('orientation' => 'orientation', 'width' => 'width', 'linewidth' => 'linewidth', 'color' => 'color', 'unit' => 'unit', 'stairstep' => 'stairstep', 'labelfont' => 'labelfont', 'labelcolor' => 'labelcolor', 'connect' => 'connect', 'mapping' => 'mapping', 'raise' => 'raise', 'icon' => 'icon', 'step' => 'step', 'anchor' => 'anchor', 'axis_loc'=>'axis_loc'); my @OptionNames = ('orientation', 'width', 'linewidth', 'color', 'anchor', 'unit', 'stairstep', 'labelfont', 'labelcolor', 'connect', 'step', 'mapping', 'range', 'raise', 'icon', 'axis_loc'); $self->{orientation} = 'horizontal'; $self->{width} = 6; $self->{linewidth} = 1; $self->{color} = 'black'; $self->{unit} = 'group'; $self->{stairstep} = 'packed'; $self->{labelfont} = '-Adobe-Helvetica-Bold-R-Normal--*-120-*'; $self->{labelcolor} = 'black'; $self->{'connect'} = ''; $self->{mapping} = sub { return @{$_[0]}; }; # anonymous default sub
# just dereferences the arg (presumably an array ref) and returns it
$self->{raise} = 0; $self->{icon} = ''; $self->{axis_loc} = 0; # Give the map a unique mapIDx tag
$self->{mapID} = 'mapID'.$Tk::bioTk_Map::mapNumber; $Tk::bioTk_Map::mapNumber++; eval bioTk_ParseArgs($self,\@ args,\@ OptionNames,\% ivars); # internally switching to 'H' & 'V' for orientation, for efficiency,
# since orientation variable is tested so often
if ($self->{orientation} eq 'horizontal') { $self->{orientation} = 'H'; } elsif ($self->{orientation} eq 'vertical') { $self->{orientation} = 'V'; } else {print STDERR "Orientation\" $self->{orientation}\" not allowed!\n"; } my $orientation = $self->{orientation}; # Setup instance variables based on orientation, etc.
if ($orientation eq 'H') { $canvas_start = $xa; $canvas_end = $xz; $canvas_min = $ya; $canvas_max = $yz; unless ($self->{anchor}) { $self->{anchor} = 's'; } } elsif ($orientation eq 'V') { $canvas_start = $ya; $canvas_end = $yz; $canvas_min = $xa; $canvas_max = $xz; unless ($self->{anchor}) { $self->{anchor} = 'e'; } } else { print STDERR "Orientation must be horizontal or vertical: ", "\"$orientation\" is not allowed\n"; return 0; } $self->{virtual_axis} = $canvas_min + $axis_loc; # MW this seems to make sense to record here
# as it is more important to know the axis
# position relative to your map coordinate system
# than the canvas coordinate system.
# This allows you to resize the map post-creation
# without messing up your coordinate system
if ($range) { $map_start = $$range[0]; $map_end = $$range[1]; } else { $map_start = $canvas_start; $map_end = $canvas_end; } $map_range = $map_end - $map_start; $canvas_range = $canvas_end - $canvas_start; $scale_factor = $canvas_range / $map_range; #/ unless ($self->{step}) { $self->{step} = $self->{width} + 1; } $self->{MapSpread} = 0; $self->{MapLabelSize} = 0; $self->{MapObjects} = []; # set MapObjects to a ref to an empty array
$self->{map_start} = $map_start; $self->{map_end} = $map_end; $self->{map_range} = $map_range; $self->{canvas_start} = $canvas_start; $self->{canvas_end} = $canvas_end; $self->{canvas_range} = $canvas_range; $self->{scale_factor} = $scale_factor; $self->{canvas_min} = $canvas_min; $self->{canvas_max} = $canvas_max; return bless $self, $package;
}
MapAxisdescriptionprevnextTop
sub MapAxis {
    my $self = shift;
    my @args = @_;
    my $canvas = $self->{canvas};
    my($dir, $side, $axis, $lbl, $xt, $yt);
    my($orientation, $linewidth, $color, $labelfont, $mapID, $axis_loc, $virt_axis_loc);
    my($map_start, $map_end, $canvas_start, $canvas_end, $scale_factor);
    my($i, $ticks, $units, $offset, $scale, $tags, @othertags, $alltags, $flip);
    $i = -1; $ticks = 0; $units = ''; $offset = 0; $scale = 1;
    # 11/13/98: Added 'nolabels' and 'axis_start' options.  --NH
my @OptionNames = ('linewidth', 'color', 'ticks', 'scale', 'units', 'offset', 'tags', 'flip', 'nolabels', 'axis_start'); eval &bioTk_ParseArgs($self,\@ args,\@ OptionNames); $orientation = $self->{orientation}; $linewidth = $self->{linewidth}; $color = $self->{color}; $labelfont = $self->{labelfont}; $mapID = $self->{mapID}; $axis_loc = $self->{axis_loc}; $virt_axis_loc = $self->{virtual_axis}; # $map_start = $self->{map_start};
$map_start = $self->{map_start} + $axis_start; # print "axis_start = $axis_start, ticks = $ticks, map_start = $map_start\n"; # DEL
$map_end = $self->{map_end} + $axis_start; $canvas_start = $self->{canvas_start}; $canvas_end = $self->{canvas_end}; $scale_factor = $self->{scale_factor}; ### Code for adding extra tags ###
if (defined($tags)) { my @othertags; if (ref($tags)) { my $tag; foreach $tag (@$tags) { push(@othertags, $tag); } } else {@othertags = ($tags); } $alltags = [@othertags, 'axis', $mapID]; } else { $alltags = ['axis', $mapID]; } # The reverse direction stuff doesn't seem to work in the Tcl version
# (or this version). The ticks and labels are left out.
# MW: the problem was with the assignment of $labelcolor, which had no value
if ($orientation eq 'V') { if ($canvas_start > $canvas_end) { $dir = -1; $side = 'e'; } else { $dir = 1; $side = 'w'; } #$offset = $self->{canvas_min} - $offset*$dir + $axis_loc;
$offset = $virt_axis_loc - $offset*$dir; # MW now we are mapping things relative to the virtual axis, instead of the canvas coordinate system
if ($linewidth) { $axis = $canvas->create('line', $offset, $canvas_start, $offset, $canvas_end, '-width' => $linewidth, '-fill' => $color, '-tags' => $alltags); } } else { if ($canvas_start > $canvas_end) { $dir = -1; $side = 'n'; } else { $dir = 1; $side = 's'; } #$offset = $self->{canvas_min} - $offset*$dir + $axis_loc;
$offset = $virt_axis_loc - $offset*$dir;# MW now we are mapping things relative to the virtual axis, instead of the canvas coordinate system
#print "offset $offset\n";
if ($linewidth) { $axis = $canvas->create('line', $canvas_start, $offset, $canvas_end, $offset, '-width' => $linewidth, '-fill' => $color, '-tags' => $alltags); } } unless ($linewidth) { $axis = ''; } if ($ticks) { for ($i=int($map_start/$ticks)*$ticks; $i<=$map_end; $i+=$ticks) {
$lbl = ($i/$scale).$units; if ($i>=$map_start) { if ($orientation eq 'H') { # horizontal orientation
$xt = $canvas_start + $scale_factor*($i-$map_start); if ($flip) { # print "flipping\n";
$xt = $canvas_end - $xt; } $canvas->create('line', $xt, $offset, $xt, $offset-5*$dir, '-width' => $linewidth, '-fill' => $color, '-tags' => $alltags); if (!$nolabels) { $canvas->create('text', $xt, $offset-6*$dir, '-anchor' => $side, '-text' => $lbl, '-font' => $labelfont, '-fill' => $color, '-tags' => $alltags); } } else { # vertical orientation
$yt = $canvas_start + $scale_factor*($i-$map_start); if ($flip) { $yt = $canvas_end - $yt; } $canvas->createLine($offset, $yt, $offset-6*$dir, $yt, '-width' => $linewidth, '-fill' => $color, '-tags' => $alltags); if (!$nolabels) { $canvas->createText($offset-20*$dir, $yt, # MW: changed it to -20 instead of -6 to prevent writing of labels over the axis
'-anchor' => $side, '-text' => $lbl, '-font' => $labelfont, '-fill' => $color, # MW: this used to be $labelcolor, which had no value so the labels didn't appear on the map
'-tags' => $alltags); } } } } } return $axis;
}
MapObjectdescriptionprevnextTop
sub MapObject {
    my $self = shift;
    my $obj = shift;    # Array of objects
my @args = @_; my @OptionNames = ('at', 'label', 'width', 'linewidth', 'color', 'anchor', 'unit', 'stairstep', 'labelfont', 'labelcolor', 'connect', 'step', 'mapping', 'range', 'raise', 'icon', 'ataxis', 'tags', 'just_labels'); ### Instance variables that can't be overridden in the method call ###
my($mapID, $canvas, $orientation, $axis_loc, $virt_axis_loc, $canvas_start, $canvas_end, $map_start, $map_end, $scale_factor, $canvas_min, $canvas_max, $MapSpread, $MapObjects); ### Option variables that default to instance variables ###
my ($width, $linewidth, $color, $anchor, $unit, $stairstep, $labelfont, $labelcolor, $connect, $step, $mapping, $range, $raise, $icon); ### Option variables that can only be specified in the method call
my($at, $label, $ataxis, $tags, $just_labels); ### variables for coordinate calculation ###
my($min_c_coord, $max_c_coord, $c_coord_first, $c_coord_last, $w2, $dir, $center, $edge1, $edge2, @m_coord, @c_coord); ### variables for object rearrangements ###
my($stepx, $stepy, $move_distance, $dir_plus, $dir_minus, $last, $posn, @new, $hit, $lap, @bb, $w, $maxi, $id); ### flags for label substitutions ###
my($label_subs_P, $label_subs_E, $label_subs_N, $label_subs_Pn,$label_subs_En,); # my($tab); # for '-apart' option
### all the rest of the method variables ###
# some involved in coords and rearrangements... #
my($elt, $n, $enum, $prev, $i, $tag_index, $lb, $lbl); $canvas = $self->{canvas}; $orientation = $self->{orientation}; $width = $self->{width}; $linewidth = $self->{linewidth}; $color = $self->{color}; $anchor = $self->{anchor}; $unit = $self->{unit}; $stairstep = $self->{stairstep}; $labelfont = $self->{labelfont}; $labelcolor = $self->{labelcolor}; $connect = $self->{'connect'}; # needed quotes to avoid -w resolution flag
$step = $self->{step}; $mapping = $self->{mapping}; $raise = $self->{raise}; $icon = $self->{icon}; $mapID = $self->{mapID}; $MapObjects = $self->{MapObjects}; $MapSpread = $self->{MapSpread}; $canvas_start = $self->{canvas_start}; $canvas_end = $self->{canvas_end}; $scale_factor = $self->{scale_factor}; $axis_loc = $self->{axis_loc}; $virt_axis_loc = $self->{virtual_axis}; $canvas_min = $self->{canvas_min}; $canvas_max = $self->{canvas_max}; $i = -1; # $at = '';
eval &bioTk_ParseArgs($self,\@ args,\@ OptionNames); # Range option allows for specification of a different range scaling
# than the range map is set up with, for single calls to MapObject
# For now ignoring the possibility that map is reversed, i.e.
# $map_end < $map_start.
if ($range) { $map_start = $$range[0]; $map_end = $$range[1]; } else { $map_start = $self->{map_start}; $map_end = $self->{map_end}; } ############### Adding any extra tags ##############
# print "Tags = $tags\n";
my($alltags, $all_but_sub_tags, @tag_sub_index, @alltags, @all_but_sub_tags, @finaltags, $tagsref); if (defined($tags)) { if (ref($tags)) { push(@alltags, @$tags); my $i=-1; foreach (@alltags) { $i++; if (/\%/) { push(@tag_sub_index,$i); } else { push(@all_but_sub_tags, $alltags[$i]); } } ###(DB) above 'foreach' instead of below 'for' so that empty loops won't be a problem (DB)
#for ($i=0; $i<=$#alltags; $i++) {
#if ($alltags[$i] =~ /\%/) { push(@tag_sub_index,$i); }
#else { push(@all_but_sub_tags, $alltags[$i]); }
#}
} else { @alltags = ($tags); if ($tags =~ /\%/) { @tag_sub_index = (1); } else { @all_but_sub_tags = ($tags); } } push(@alltags, $mapID, 'new'); push(@all_but_sub_tags, $mapID, 'new'); # print "AllTags = ", @alltags,"\n";
# print "AllButSubTags = ", @all_but_sub_tags, "\n";
# print "TagSubIndex = ", @tag_sub_index, "\n";
} else { @alltags = ($mapID, 'new'); @all_but_sub_tags = @alltags; } $alltags =\@ alltags; $all_but_sub_tags =\@ all_but_sub_tags; ########################################################
##### Skipping options at the moment
##### Working out boundaries perpendicular to axis #####
# print "axis loc: $axis_loc virtual $virt_axis_loc canvas_min $canvas_min canvas_max $canvas_max ataxis $ataxis \n";
if (defined($at)) { if (!(ref($at))) { $canvas_min = $canvas_max = $at; } elsif (ref($at) eq 'ARRAY') { if ($#$at == 0) { $canvas_max = $canvas_min = $$at[0]; } else { $canvas_min = $$at[0]; $canvas_max = $$at[1]; } } elsif ($at eq 'axis') { # $canvas_min += $axis_loc;
$canvas_min = $virt_axis_loc; # MW now relative to map coords, not real coords
$canvas_max = $canvas_min; } } elsif (defined($ataxis)) { if (ref($ataxis)) { my $temp_min = $canvas_min; #$canvas_min = $canvas_min + $axis_loc + $$ataxis[0];
$canvas_min = $virt_axis_loc + $$ataxis[0]; #MW relative coords
if ($#$ataxis == 0) { $canvas_max = $canvas_min; } else { #$canvas_max = $temp_min + $axis_loc + $$ataxis[1]; }
$canvas_max = $virt_axis_loc + $$ataxis[1]; #MW relative coords
} } else { #$canvas_min = $canvas_min + $axis_loc + $ataxis;
$canvas_min = $virt_axis_loc + $ataxis; #MW relative coords
$canvas_max = $canvas_min; } } # print "canvas min now $canvas_min\n";
# else no -at or -ataxis options, so $canvas_min and $canvas_max
# stay as set in $self->{canvas_min} and $self->{canvas_max}
if ($canvas_min < $canvas_max) { # start at $canvas_min and move towards $canvas_max
$dir = 1; } elsif ($canvas_min > $canvas_max) { # start at $canvas_max and move towards $canvas_min
$dir = -1; } else { # $canvas_min equals $canvas_max, don't move at all
# dir = 0 flags to not worry about moving objects
$dir = 0; } $step = $dir * $step; # added 8/8/95 to allow "reverse" placement
# of objects
$move_distance = $step; $center = $canvas_min; $w2 = int($width/2);
$edge1 = $center-$w2; # used to be $yb
$edge2 = $center+$w2; # used to be $yf
##########################################################
# Redid these -- they were screwing up the '-connect' option
# $max = 0; $min = 9999999;
# $max_c_coord and $min_c_coord are used to determine where to center
# group labels, connect lines, and some stairstepping stuff...
$max_c_coord = $canvas_start; # used to be $max
$min_c_coord = $canvas_end; # used to be $min
$canvas->dtag('new', 'new'); # last object(s) is no longer new
if ($raise) { print "No raise!\n"; exit 0; } $prev = 'none'; $enum = 0; #### Setting orientation-specific variables ####
## $stepx and $stepy are references to allow orientation-independent
## changing step in stairstepping mode
if ($orientation eq 'H') { # horizontal orientation
$stepx =\0 ; $stepy =\$ move_distance; $dir_plus = 3; $dir_minus = 1; } else { # vertical orientation
$stepx =\$ move_distance; $stepy =\0 ; $dir_plus = 2; $dir_minus = 0; } ################################################
### Setting up icon subroutine ref ###
# should add in 'line' default $icon at some point...
unless (ref($icon)) { # if ref then just call ref'ed sub
if (!$icon) { # default ($icon = '')
$icon =\& MapRectangle; } # default is rectangle
elsif ($icon eq 'oval') { $icon =\& MapOval; } elsif ($icon eq 'diamond') { $icon =\& MapDiamond; } elsif ($icon eq 'triangle') { $icon =\& MapTriangle; } elsif ($icon eq 'rectangle') { $icon =\& MapRectangle; } } ### Setting up label substitution flags ###
if (defined($label)) { if ($label =~ /\%/) { if ($label =~ /\%[PE]\d/) { if ($label =~ /\%P\d/) { $label_subs_Pn = 1; } if ($label =~ /\%E\d/) { $label_subs_En = 1; } } if ($label =~ /\%[PE]\D/) { if ($label =~ /\%P\D/) { $label_subs_P = 1; } if ($label =~ /\%E\D/) { $label_subs_E = 1; } } if ($label =~ /\%N/) { $label_subs_N = 1; } } } ############### Main loop over each element in the object ###############
foreach $elt (@$obj) { $enum++; @m_coord = &$mapping($elt); # @m_coord replaces @s from Tcl version
$n = $#m_coord + 1; #### convert map coordinates to canvas coordinates ####
# @c_coord replaces $x0, $x1, $x2, $x3 from Tcl version
@c_coord = map($canvas_start + $scale_factor * ($_-$map_start), @m_coord); $c_coord_first = $c_coord[0]; # used to be $x0
$c_coord_last = $c_coord[$#c_coord]; # used to be $xn (for horizontal)
if ($n == 4) { # object is a span within a span
# therefore just want to center group label on inner span
if ($c_coord[1] < $min_c_coord) {$min_c_coord = $c_coord[1];} if ($c_coord[2] > $max_c_coord) {$max_c_coord = $c_coord[2];} } else { if ($c_coord_first < $min_c_coord) {$min_c_coord = $c_coord_first;} if ($c_coord_last > $max_c_coord) { $max_c_coord = $c_coord_last; } } ### Substitutions for tags ###
@finaltags = @alltags; $tagsref =\@ finaltags; foreach $tag_index (@tag_sub_index) { $finaltags[$tag_index] =~ s/\%N/$enum/; } ### Substitutions for labels ###
if (defined($label)) { $lb = $label; if ($label_subs_P) { my $all_mapped_coords = join(', ',@m_coord); $lb =~ s/\%P(\D)/$all_mapped_coords$1/g; } if ($label_subs_E) { my $all_indirect_refs = join(', ',@$elt); $lb =~ s/\%E(\D)/$all_indirect_refs$1/g; } if ($label_subs_N) { $lb =~ s/\%N/$enum/g; } if ($label_subs_Pn) { $lb =~ s/\%P(\d)/$m_coord[$1]/g; } if ($label_subs_En) { $lb =~ s/\%E(\d)/$$elt[$1]/g; } } ########## Drawing Individual Objects #########
## all objects initially have tags 'new' and $mapID (in $tagsref)##
#### Switch: only want label, not object
if (defined($just_labels)) { } # do nothing if just want labels
#### object is a point
elsif ($n == 1) { # took out +/- $w2 for $x0 -- I think it should be a point,
# and let the icon sub deal with making it larger if desired
&$icon($self, $orientation, $c_coord[0], $edge1, $c_coord[0], $edge2, $color, $linewidth, $tagsref); } #### object is a span
elsif ($n == 2) { &$icon($self, $orientation, $c_coord[0], $edge1, $c_coord[1], $edge2, $color, $linewidth, $tagsref); } #### object is a point within a span
elsif ($n == 3) { &MapRangeBars($self, $orientation, $c_coord[0], $edge1, $c_coord[2], $edge2, $color, $linewidth, $tagsref); &$icon($self, $orientation, $c_coord[1], $edge1, $c_coord[1], $edge2, $color, $linewidth, $tagsref); } #### object is a span within a span
elsif ($n == 4) { &MapSimpleLine($self, $orientation, $c_coord[0], $center, $c_coord[3], $center, $color, $linewidth, $tagsref); &$icon($self, $orientation, $c_coord[1], $edge1, $c_coord[2], $edge2, $color, $linewidth, $tagsref); } ## dealing with drawing splice lines if needed
if (($prev ne 'none') && ($connect eq 'spliced')) { &MapSpliceLine($self, $orientation, $prev, $center, $c_coord[0], $edge1, $color, $linewidth, $all_but_sub_tags); } $prev = $c_coord_last; ############ Drawing Labels ###########
if ($label && ($unit eq 'each')) { for ($i=0; $i<$n; $i++) { # Substitution stuff left out...
} # More substitution stuff left out...
if ($anchor eq 'apart') { # $self->MapInsertApart($tab, $canvas_start, $canvas_end,
# $edge2, $canvas_max, $dir, $lb, $labelcolor,
# $labelfont, $color, $orientation);
print "Apart stuff not implemented yet!\n"; exit 0; } else { # Raise stuff left out...
$self->MapObjectLabel($canvas, $c_coord_first, $edge1, $c_coord_last, $edge2, $anchor, $orientation, $lb, $labelfont, $labelcolor, $tagsref ); } } } # closes foreach $elt
################# End of main loop over object elements #################
########### Drawing connecting lines ##############
if ($connect) { # skip this section if $connect eq ''
if ($connect eq 'spliced') { } elsif ($connect eq 'dashed') { $canvas->lower(&MapBrokenLine($self, $orientation, $min_c_coord, $center, $max_c_coord, $center, $color, $linewidth, $all_but_sub_tags, 'dashed')); } elsif ($connect eq 'dotted') { $canvas->lower(&MapBrokenLine($self, $orientation, $min_c_coord, $center, $max_c_coord, $center, $color, $linewidth, $all_but_sub_tags, 'dotted' ) );; } else { # should redo the lower part of this to just lower it below
# the items currently being mapped -- right now it's being
# lowered to 1 (rather than to 0/default) so that in
# applications a selection rectangle can enclose the items
# and still not obscure the connecting line
$canvas->lower(&MapSimpleLine($self, $orientation, $min_c_coord, $center, $max_c_coord, $center, $connect, $linewidth, $all_but_sub_tags)); # had to take out lowering to 1 -- STSTut was having problems, since
# nothing had been mapped yet.
# '-width' => $linewidth), 1);
} } ############ Drawing Group labels #############
if ($label && ($unit eq 'group')) { if ($anchor eq 'apart') { # $self->MapInsertApart($tab, $canvas_start, $canvas_end,
# $edge2, $canvas_max, $dir, $lb, $labelcolor,
# $labelfont, $color, $orientation);
print "Apart stuff not implemented yet!\n"; exit 0; } else { # anchor not apart
# left out raise stuff...
# NEED to CHANGE this when label substitution is coded
$lbl = $self->MapObjectLabel($canvas, $min_c_coord, $edge1, $max_c_coord, $edge2, $anchor, $orientation, $lb, $labelfont, $labelcolor, $all_but_sub_tags ); } } ############ Rearranging Drawn Items ###############
if ($dir && ($anchor ne 'apart')) { ##### Rarrange in 'packed' mode (no stairstepping) #####
if ($stairstep eq 'packed') { @new = $canvas->find('withtag' => 'new'); $hit = 1; # _Really_ should rewrite this section to perlize it
while ($hit) { $hit = 0; foreach $n (@new) { @bb = $canvas->bbox($n); foreach $lap ($canvas->find('overlapping',@bb)) { unless (grep(/$lap/,@new)) { $hit=1; last; } } if ($hit) { last; } } if ($hit) { ## use references to be consistent with stairstepping move
$canvas->move('new', $$stepx, $$stepy); } # Checking to see if exceeded allowed area
@bb = $canvas->bbox('new'); if ($dir>0) { if ($bb[$dir_plus] > $canvas_max) { last; } } else { if ($bb[$dir_minus] < $canvas_max) { last; } } } } ##### Stairstepping in 'forward'/'backward' mode #####
else { # if $stairstep _not_ 'packed'...
$i = 0; foreach $w (@$MapObjects) { if ($stairstep eq 'forward') { if (($max_c_coord==$$w[2] && $min_c_coord>=$$w[1]) || $max_c_coord>$$w[2]) { last; } } else { if (($min_c_coord==$$w[1] && $max_c_coord<=$$w[2]) || $min_c_coord<$$w[1]) { last; } } $i++; } # I think since $MapObjects is a reference,
# modifying @$MapObjects is effectively modifying
# $self->{MapObjects}, so don't need to reassign it
splice (@$MapObjects, $i, 0, [$center, $min_c_coord, $max_c_coord, [$canvas->find('withtag'=>'new')] ]); if ($MapSpread) { $hit =1; } else { $hit = 0; @new = $canvas->find('withtag' => 'new'); foreach $n (@new) { foreach $lap ($canvas->find('overlapping', $canvas->bbox($n))) { unless (grep(/$lap/,@new)) { $hit=1; last; } } if ($hit) { $MapSpread = 1; $self->{MapSpread} = 1; last; } } } if ($hit) { my @newobjects; # pushed out the int because of Tcl/Perl division diffs...
$maxi = int(abs($canvas_min-$canvas_max)/$step); #/ $i = 0; @newobjects = (); foreach $w (@$MapObjects) { $last = $$w[0]; $posn = $canvas_min + ($i%$maxi) * $dir * $step; my $neww = [@$w]; $$neww[0] = $posn; push(@newobjects, $neww); $move_distance = $posn-$last; foreach $id (@{$$w[3]}) { # Got rid of orientation dependence here by using
# references -- I'm not sure if this was a good idea
# though. It might be clearer if I just did an
# orientation-dependent conditional here...
# Differences based on orientation have been set
# up earlier via references:
# if horizontal, $stepx = \0, $stepy = \$move_distance
# if vertical, $stepx = \$move_distance, $stepy = \0
$canvas->move($id, $$stepx, $$stepy); } $i++; } $MapObjects =\@ newobjects; $self->{MapObjects} = $MapObjects; } } # closes 'backward'/'forward' stairstepping option
} # closes if ($dir &&....) conditional for rearranging objects
return $canvas->find('withtag' => 'new');
}
MapObjectLabeldescriptionprevnextTop
sub MapObjectLabel {
    my $self = shift;
    my($canvas, $c_start, $c_edge1, $c_end, $c_edge2, 
       $anchor, $orientation, $label, $font, $color, $tags) = @_ ;
    my($x0,$y0,$x1,$y1);
    my($tmp,@data);
    if ($orientation eq 'H')  {
	$x0 = $c_start; $x1 = $c_end;
	$y0 = $c_edge1; $y1 = $c_edge2;    }
    else  { 	
	$x0 = $c_edge1; $x1 = $c_edge2;
	$y0 = $c_start; $y1 = $c_end;      }
	
    if ($x0>$x1) { $tmp = $x0; $x0 = $x1; $x1 = $tmp; }
    if ($y0>$y1) { $tmp = $y0; $y0 = $y1; $y1 = $tmp; }
    $x0 = $x0-2; 
    $x1 = $x1+2;
    #print "x0 = $x0 = $c_start, x1 = $x1 = $c_end\n";
#print "y0 = $y0 = $c_edge1, y1 = $y1 = $c_edge2\n";
push @{$tags}, "bioTk_Map_Label"; @data = ('-text'=>$label, '-font'=>$font, '-fill'=>$color, '-tags'=>$tags, '-width'=>0); if ($anchor eq 'n') { return $canvas->create('text', ($x0+$x1)/2, $y0, '-anchor' => 's', #/ '-justify' => 'center', @data); } elsif ($anchor eq 's') { return $canvas->create('text', ($x0+$x1)/2, $y1, '-anchor' => 'n', #/ '-justify' => 'center', @data); } elsif ($anchor eq 'w') { return $canvas->create('text', $x0, ($y0+$y1)/2, '-anchor' => 'e', #/ '-justify' => 'right', @data); } elsif ($anchor eq 'e') { return $canvas->create('text', $x1, ($y0+$y1)/2, '-anchor' => 'w', #/ '-justify' => 'left', @data); } elsif ($anchor eq 'nw') { if ($orientation eq 'V') { return $canvas->create('text', $x0, $y0, '-anchor' => 'ne', '-justify' => 'right', @data); } else { return $canvas->create('text', $x0, $y0, '-anchor' => 'sw', '-justify' => 'left', @data); } } elsif ($anchor eq 'ne') { if ($orientation eq 'V') { return $canvas->create('text', $x1, $y0, '-anchor' => 'nw', '-justify' => 'left', @data); } else { return $canvas->create('text', $x1, $y0, '-anchor' => 'se', '-justify' => 'right', @data); } } elsif ($anchor eq 'sw') { if ($orientation eq 'V') { return $canvas->create('text', $x0, $y1, '-anchor' => 'se', '-justify' => 'right', @data); } else { return $canvas->create('text', $x0, $y1, '-anchor' => 'nw', '-justify' => 'left', @data); } } elsif ($anchor eq 'se') { if ($orientation eq 'V') { return $canvas->create('text', $x1, $y1, '-anchor' => 'sw', '-justify' => 'left', @data); } else { return $canvas->create('text', $x1, $y1, '-anchor' => 'ne', '-justify' => 'right', @data); } } elsif ($anchor eq 'center') { return $canvas->create('text', ($x0+$x1)/2, ($y0+$y1)/2, '-anchor'=>'center', '-justify'=>'center', @data); } else { print "Anchor value $anchor not recognized!!\n"; exit 0; }
}
MapResetdescriptionprevnextTop
sub MapReset {
    my $self = shift;
    $self->{MapObjects} = [];
    $self->{MapLabelSize} = 0;
    $self->{MapSpread} = 0;
    return 1;
}
MapPositiondescriptionprevnextTop
sub MapPosition {
  #  Usage: $map_coord = $map->MapPosition($canvas_coord)
# Returns a map coordinate for a given canvas coordinate
#
# Note that orientation doesn't matter -- it's been abstracted
# For efficiency, should probably just do a return and not assign
# any local variables, but this is much more readable
# Returns a float -- leave rounding/inting up to the caller
# (could add an optional arg for how many decimal places to return...)
my($self, $canvas_coord, $map_start, $canvas_start, $scale_factor); $self = shift; $canvas_coord = shift; $map_start = $self->{map_start}; $canvas_start = $self->{canvas_start}; $scale_factor = $self->{scale_factor}; return $map_start + ($canvas_coord - $canvas_start) / $scale_factor;
} #/
}
MapLocationdescriptionprevnextTop
sub MapLocation {
  #  Usage: $canvas_coord = $map->MapLocation($map_coord)
# Returns a canvas coordinate for a given map coordinate
#
# Note that orientation doesn't matter -- it's been abstracted
# For efficiency, should probably just do a return and not assign
# any local variables, but this is much more readable
# Returns a float -- leave rounding/inting up to the caller
my($self, $map_coord, $map_start, $canvas_start, $scale_factor); $self = shift; $map_coord = shift; $map_start = $self->{map_start}; $canvas_start = $self->{canvas_start}; $scale_factor = $self->{scale_factor}; return $canvas_start + $scale_factor * ($map_coord - $map_start); } #########################################################################
#
# Icon Drawing subs
#
#########################################################################
# Argument list to icon drawing subs:
# $self = $_[0]; # the map object
# $orientation = $_[1]; # 'H' for horizontal or 'V' for vertical
# $c_start = $_[2]; # start of object, along map axis
# $c_edge1 = $_[3]; # 1rst boundary of object, perpendicular to map axis
# $c_end = $_[4]; # end of object, along map axis
# $c_edge2 = $_[5]; # 2nd boundary of object, perpendicular to map axis
# $color = $_[6];
# $linewidth = $_[7];
# $tags = $_[8];
}
MapBrokenLinedescriptionprevnextTop
sub MapBrokenLine {
    my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags, $linetype) = @_;
    my($d, $max, $incr, $incr2, $canvas);
    $canvas = $self->{canvas};
    $max = $c_end - $linewidth*5;
    # if $linetype arg not present, use dashed defaults
if (!$linetype || ($linetype eq 'dashed')) { $incr = $linewidth*5; $incr2 = $linewidth*3; } elsif ($linetype eq 'dotted') { $incr = $linewidth*3; $incr2 = $linewidth; } ### should add option for $linetype = [$incr $incr2]
if ($orientation eq 'H') { for ($d=$c_start+$linewidth; $d<$max; $d+=$incr) { $canvas->create('line', $d, $c_edge1, $d+$incr2, $c_edge2, '-tags'=>$tags, '-fill'=>$color, '-width'=>$linewidth); } } else { for ($d=$c_start+$linewidth; $d<$max; $d+=$incr) { $canvas->create('line', $c_edge1, $d, $c_edge2, $d+$incr2, '-tags'=>$tags, '-fill'=>$color, '-width'=>$linewidth); } }
}
MapTriangledescriptionprevnextTop
sub MapTriangle {
    my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags) = @_;
    my $axis_mid = ($c_start + $c_end)/2;      #/
    if ($orientation eq 'H')  {
	$self->{canvas}->create('polygon', $c_start, $c_edge2, 
				$axis_mid, $c_edge1, $c_end, $c_edge2,
				'-fill'=>$color, '-tags'=>$tags);
    }
    else {
	$self->{canvas}->create('polygon', $c_edge2, $c_start,
				$c_edge1, $axis_mid, $c_edge2, $c_end,
				'-fill'=>$color, '-tags'=>$tags);
    }
}
MapDiamonddescriptionprevnextTop
sub MapDiamond {
    my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags) = @_;
    my($axis_mid, $edge_mid);
    $axis_mid = ($c_start + $c_end)/2;
$edge_mid = ($c_edge1 + $c_edge2)/2;
if ($orientation eq 'H') { $self->{canvas}->create('polygon', $c_start, $edge_mid, $axis_mid, $c_edge1, $c_end, $edge_mid, $axis_mid, $c_edge2, '-fill'=>$color, '-tags'=>$tags); } else { $self->{canvas}->create('polygon', $edge_mid, $c_start, $c_edge1, $axis_mid, $edge_mid, $c_end, $c_edge2, $axis_mid, '-fill'=>$color, '-tags'=>$tags); }
}
MapOvaldescriptionprevnextTop
sub MapOval {
     my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags) = @_;
    # adjust start and end if object is "too" small
if (abs($c_start-$c_end) < 6) { my $c_mid = ($c_start + $c_end) / 2; #/ $c_start = $c_mid - 3; $c_end = $c_mid + 3; } if ($orientation eq 'H') { $self->{canvas}->create('oval', $c_start, $c_edge1, $c_end, $c_edge2, '-fill'=>$color, '-outline'=>undef, '-tags'=>$tags); } else { $self->{canvas}->create('oval', $c_edge1, $c_start, $c_edge2, $c_end, '-fill'=>$color, '-outline'=>undef, '-tags'=>$tags); }
}
MapRectangledescriptionprevnextTop
sub MapRectangle {
  #  Could assign my vars, but will use straight @_ list for efficiency
# Never mind, switched back to assigned vars
# Actually, this doesn't seem to matter -- I think the time spent
# assigning "my" variables is minor compared to the time spent in the
# Tk canvas 'create' subs
my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2, $color, $linewidth, $tags) = @_; if($orientation eq 'H') { # orientation is horizontal
# therefore start/end are x coords, edges are y coords
$self->{canvas}->create('rectangle', $c_start, $c_edge1, $c_end, $c_edge2, '-fill' => $color, '-outline' => undef, '-tags' => $tags); } else { # orientation is vertical
# therefore start/end are y coords, edges are x coords
$self->{canvas}->create('rectangle', $c_edge1, $c_start, $c_edge2, $c_end, '-fill' => $color, '-outline' => undef, '-tags' => $tags); }
}
MapSimpleLinedescriptionprevnextTop
sub MapSimpleLine {
    my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags) = @_;
    if ($orientation eq 'H')  {
        $self->{canvas}->create('line', $c_start, $c_edge1, $c_end, $c_edge2,
				'-fill'=> $color, '-width'=> $linewidth,
				'-tags'=> $tags);
    }
    else  {
	$self->{canvas}->create('line', $c_edge1, $c_start, $c_edge2, $c_end,
				'-fill'=> $color, '-width'=> $linewidth,
				'-tags'=> $tags);
    }
}
MapSpliceLinedescriptionprevnextTop
sub MapSpliceLine {
    my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags) = @_;
    if ($orientation eq 'H')  {
	$self->{canvas}->create('line', $c_start, $c_edge1, 
			       ($c_start+$c_end)/2, $c_edge2, $c_end, $c_edge1,
'-tags' =>
$tags, '-fill' => $color,
'-width' =>
$linewidth, '-capstyle'=>'round');
} else { $self->{canvas}->create('line', $c_edge1, $c_start, $c_edge2, ($c_start+$c_end)/2, $c_edge1, $c_end,
'-tags' =>
$tags, '-fill' => $color,
'-width' =>
$linewidth, '-capstyle'=>'round');
}
}
MapRangeBarsdescriptionprevnextTop
sub MapRangeBars {
    my($self, $orientation, $c_start, $c_edge1, $c_end, $c_edge2,
       $color, $linewidth, $tags) = @_;
    my($canvas, $mid);
    $canvas = $self->{canvas};
    $mid = ($c_edge1 + $c_edge2) / 2;
if ($orientation eq 'H') { # horizontal orientation
$canvas->create('line', $c_start, $mid, $c_end, $mid, '-fill'=>$color, '-width'=>$linewidth, '-tags'=>$tags); $canvas->create('line', $c_start, $c_edge1, $c_start, $c_edge2, '-fill'=>$color, '-width'=>$linewidth, '-tags'=>$tags); $canvas->create('line', $c_end, $c_edge1, $c_end, $c_edge2, '-fill'=>$color, '-width'=>$linewidth, '-tags'=>$tags); } else { # vertical orientation
$canvas->create('line', $mid, $c_start, $mid, $c_end, '-fill'=>$color, '-width'=>$linewidth, '-tags'=>$tags); $canvas->create('line', $c_edge1, $c_start, $c_edge2, $c_start, '-fill'=>$color, '-width'=>$linewidth, '-tags'=>$tags); $canvas->create('line', $c_edge1, $c_end, $c_edge2, $c_end, '-fill'=>$color, '-width'=>$linewidth, '-tags'=>$tags); } } ###########################################################
# Debugging subroutines
}
prMapObjectsdescriptionprevnextTop
sub prMapObjects {
    my $MapObjects = shift;
    my $obj;
    print "MapObjects: ";
    foreach $obj (@$MapObjects) { &prMapObject($obj); }
    print "\n";
}
prMapObjectdescriptionprevnextTop
sub prMapObject {
    my $obj = shift;
    my $el;
    print "{";
    print "$$obj[0] $$obj[1] $$obj[2] ";
    print "{";
    foreach $el (@{$$obj[3]})  { print "$el "; }
    print "}";
    print "} ";
}


1;

__END__

#########  Bits of work in progress  ##########
# starting work on '-apart' option subs
}
MapInsertApartdescriptionprevnextTop
sub MapInsertApart {
    my ($self, $tab, $canvas_start, $canvas_end, $edge2, $canvas_max, 
	$dir, $lb, $labelcolor, $labelfont, $color, $orientation) = @_;
    my($canvas, $MapObjects);
    my($lbl, $lin);
    $canvas = $self->{canvas};
    $MapObjects = $self->{MapObjects};
    $lbl = $canvas->create('text', $tab, $canvas_max+4*$dir, '-anchor'=>'n',
			   '-tags'=>['new',$mapID], '-justify'=>'center',
			   '-text'=>$lb, '-fill'=>$labelcolor, 
			   '-font'=>$labelfont);
    $line = $canvas->create('line', $tab, $edge2, $tab, $canvas_max, 
			    '-fill'=>$color, '-tags'=>['new',$mapID]);

}
# $tab stuff, only used for labels with '-apart' option
$tab = $$c_coord[0]; # n == 1
$tab = ($c_coord[1]-$c_coord[0])/2; # n == 2
$tab = $c_coord[1]; # n == 3
$tab = ($c_coord[2] - $c_coord[1])/2; # n == 4
}
General documentation
No general documentation available.