1package Bio::Graphics::Glyph::merge_parts;
2
3use strict;
4use base qw(Bio::Graphics::Glyph);
5
6sub my_description {
7    return <<END;
8This is a base class for graded_segments, heterogeneous_segments,
9and merged_alignment.
10
11It adds internal methods to support semantic zooming of scored
12alignment features. It is not intended for end users.
13END
14}
15
16sub my_options {
17    {
18	max_gap => [
19	    'integer',
20	    undef,
21	    'This is the maximum gap, measured in bp, across which the glyph will',
22	    'attempt to merge subfeatures in an attempt to simplify the appearance',
23	    'at low magnifications. If undef, the max_gap will be calculated using',
24	    'a simple exponential heuristic.'],
25    }
26}
27
28sub merge_parts {
29    my ($self,@parts)  = @_;
30
31    # This is the largest gap across which adjacent segments will be merged
32    my $max_gap = $self->max_gap;
33
34    my $last_part;
35
36    my @sorted_parts = sort {$a->start <=> $b->start} @parts;
37
38    for my $part (@sorted_parts) {
39        if ($last_part) {
40            my $start  = $part->start;
41            my $end    = $part->stop;
42            my $score  = $part->score;
43            my $pstart = $last_part->start;
44            my $pend   = $last_part->stop;
45            my $pscore = $last_part->score || 0;
46            my $len    = 1 + abs($end - $start);
47            my $plen   = 1 + abs($pend - $pstart);
48
49            # weighted average score
50            my $new_score = (($score*$len)+($pscore*$plen))/($len+$plen);
51
52            # don't merge if there is a gap > than the allowed size
53            my $gap   = abs($start - $pend);
54            my $total = abs($end - $pstart);
55
56	    my $last_f = $last_part->feature;
57            if ($gap > $max_gap) {
58                $last_part = $part;
59                next;
60            }
61
62            $part->{start}    = $pstart;
63            $part->{score}    = $new_score;
64            my ($left,$right) = $self->map_pt($pstart,$end+1);
65            $part->{left}     = $left;
66            $part->{width}    = ($right - $left) + 1;
67
68            # flag the left feature for removal
69            $last_part->{remove} = 1;
70        }
71
72        $last_part = $part;
73
74    }
75
76    @parts =  grep {!defined $_->{remove}} @parts;
77
78    return @parts;
79}
80
81sub max_gap {
82    my $self = shift;
83    $self->panel->{max_gap} ||= $self->option('max_gap');
84    return $self->panel->{max_gap} || $self->calculate_max_gap;
85}
86
87sub calculate_max_gap {
88    my $self = shift;
89    my $segment_length = $self->panel->length;
90
91    # allow more aggressive merging for larger segments
92    # by exponentially increasing max_gap
93    my $max_gap = ($segment_length/10000)*($segment_length/500);
94
95    $self->panel->{max_gap} = $max_gap;
96
97    return $max_gap;
98}
99
1001;
101
102__END__
103
104=head1 NAME
105
106Bio::Graphics::Glyph::merge_parts - a base class which suppors semantic zooming of scored alignment features
107
108=head1 SYNOPSIS
109
110  See L<Bio::Graphics::Panel> and L<Bio::Graphics::Glyph>.
111
112=head1 DESCRIPTION
113
114This is a base class for
115Bio::Graphics::Glyph::graded_segments,
116Bio::Graphics::Glyph::heterogeneous_segments
117and Bio::Graphics::Glyph::merged_alignment.
118It adds internal methods to support semantic zooming of scored
119alignment features. It is not intended for end users.
120
121=head1 BUGS
122
123Please report them.
124
125=head1 SEE ALSO
126
127L<Bio::Graphics::Panel>,
128L<Bio::Graphics::Track>,
129L<Bio::Graphics::Glyph::graded_segments>
130L<Bio::Graphics::Glyph::heterogeneous_segments>
131L<Bio::Graphics::Glyph::merged_alignment>
132
133=head1 AUTHOR
134
135Sheldon McKay E<lt>mckays@cshl.eduE<gt>
136
137Copyright (c) 2005 Cold Spring Harbor Laboratory
138
139    This library is free software; you can redistribute it and/or modify
140it under the same terms as Perl itself.  See DISCLAIMER.txt for
141disclaimers of warranty.
142
143=cut
144