← Back to branch summary

~ubuntu-branches/ubuntu/raring/bioperl/raring

« back to all changes in this revision

Viewing changes to Bio/Graphics/Glyph/xyplot.pm

  • Committer: Bazaar Package Importer
  • Author(s): Charles Plessy
  • Date: 2008-03-18 14:44:57 UTC
  • mfrom: (4 hardy)
  • mto: This revision was merged to the branch mainline in revision 6.
  • Revision ID: james.westby@ubuntu.com-20080318144457-1jjoztrvqwf0gruk
http://bugs.debian.org/448890
* debian/control:
  - Removed MIA Matt Hope (dopey) from the Uploaders field.
    Thank you for your work, Matt. I hope you are doing well.
  - Downgraded some recommended package to the 'Suggests' priority,
    according to the following discussion on Upstream's mail list.
    http://bioperl.org/pipermail/bioperl-l/2008-March/027379.html
    (Closes: #448890)
* debian/copyright converted to machine-readable format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Graphics/Glyph/xyplot.pm
1
1
package Bio::Graphics::Glyph::xyplot;
2
2
 
3
3
use strict;
4
 
use Bio::Graphics::Glyph::minmax;
5
 
use vars '@ISA';
6
4
#use GD 'gdTinyFont';
7
5
 
8
 
@ISA = 'Bio::Graphics::Glyph::minmax';
 
6
use base qw(Bio::Graphics::Glyph::minmax);
9
7
 
10
 
use constant DEFAULT_POINT_RADIUS=>1;
 
8
use constant DEFAULT_POINT_RADIUS=>4;
11
9
 
12
10
my %SYMBOLS = (
13
11
               triangle => \&draw_triangle,
16
14
               point    => \&draw_point,
17
15
              );
18
16
 
 
17
# Default pad_left is recursive through all parts. We certainly
 
18
# don't want to do this for all parts in the graph.
 
19
sub pad_left {
 
20
  my $self = shift;
 
21
  return 0 unless $self->level == 0;
 
22
  return $self->SUPER::pad_left(@_);
 
23
}
 
24
 
 
25
# Default pad_left is recursive through all parts. We certainly
 
26
# don't want to do this for all parts in the graph.
 
27
sub pad_right {
 
28
  my $self = shift;
 
29
  return 0 unless $self->level == 0;
 
30
  return $self->SUPER::pad_right(@_);
 
31
}
 
32
 
19
33
sub point_radius {
20
34
  shift->option('point_radius') || DEFAULT_POINT_RADIUS;
21
35
}
22
36
 
23
 
sub pad_top { 0 }
 
37
sub pad_top {
 
38
  shift->Bio::Graphics::Glyph::generic::pad_top(@_);
 
39
}
 
40
 
 
41
sub pad_bottom {
 
42
  my $self = shift;
 
43
  my $pad  = $self->Bio::Graphics::Glyph::generic::pad_bottom(@_);
 
44
  if ($pad < ($self->font('gdTinyFont')->height)/4) {
 
45
    $pad = ($self->font('gdTinyFont')->height)/4;  # extra room for the scale
 
46
  }
 
47
}
 
48
 
 
49
sub default_scale
 
50
{
 
51
  return 'right';
 
52
}
24
53
 
25
54
sub draw {
26
55
  my $self = shift;
 
56
 
27
57
  my ($gd,$dx,$dy) = @_;
28
58
  my ($left,$top,$right,$bottom) = $self->calculate_boundaries($dx,$dy);
29
 
 
30
59
  my @parts = $self->parts;
 
60
 
31
61
  return $self->SUPER::draw(@_) unless @parts > 0;
32
62
 
33
63
  my ($min_score,$max_score) = $self->minmax(\@parts);
34
64
 
 
65
  my $side = $self->_determine_side();
 
66
 
35
67
  # if a scale is called for, then we adjust the max and min to be even
36
68
  # multiples of a power of 10.
37
 
  if ($self->option('scale')) {
 
69
  if ($side) {
38
70
    $max_score = max10($max_score);
39
71
    $min_score = min10($min_score);
40
72
  }
41
73
 
42
 
  my $height = $self->option('height');
 
74
  my $height = $self->height;
43
75
  my $scale  = $max_score > $min_score ? $height/($max_score-$min_score)
44
76
                                       : 1;
45
 
  my $x = $dx;
46
 
  my $y = $dy + $self->top + $self->pad_top;
 
77
 
 
78
  my $x = $left;
 
79
  my $y = $top + $self->pad_top;
 
80
 
 
81
  # position of "0" on the scale
 
82
  my $y_origin = $min_score <= 0 ? $bottom - (0 - $min_score) * $scale : $bottom;
 
83
  $y_origin    = $top if $max_score < 0;
 
84
 
 
85
  my $clip_ok = $self->option('clip');
 
86
  $self->{_clip_ok}   = $clip_ok;
 
87
  $self->{_scale}     = $scale;
 
88
  $self->{_min_score} = $min_score;
 
89
  $self->{_max_score} = $max_score;
 
90
  $self->{_top}       = $top;
 
91
  $self->{_bottom}    = $bottom;
47
92
 
48
93
  # now seed all the parts with the information they need to draw their positions
49
94
  foreach (@parts) {
50
 
    my $s = eval {$_->feature->score};
 
95
    my $s = $_->score;
51
96
    next unless defined $s;
52
 
    my $position      = ($s-$min_score) * $scale;
53
 
    $_->{_y_position} = $bottom - $position;
54
 
  }
55
 
 
56
 
  my $type = $self->option('graph_type');
57
 
  $self->_draw_histogram($gd,$x,$y)  if $type eq 'histogram';
58
 
  $self->_draw_boxes($gd,$x,$y)      if $type eq 'boxes';
59
 
  $self->_draw_line ($gd,$x,$y)      if $type eq 'line'
60
 
                                       or $type eq 'linepoints';
61
 
  $self->_draw_points($gd,$x,$y)     if $type eq 'points'
62
 
                                       or $type eq 'linepoints';
63
 
 
64
 
  $self->_draw_scale($gd,$scale,$min_score,$max_score,$dx,$dy)      if $self->option('scale');
 
97
    $_->{_y_position}   = $self->score2position($s);
 
98
  }
 
99
 
 
100
  my $type        = $self->option('graph_type') || $self->option('graphtype') || 'boxes';
 
101
  my $draw_method = $self->lookup_draw_method($type);
 
102
  $self->throw("Invalid graph type '$type'") unless $draw_method;
 
103
  $self->$draw_method($gd,$x,$y,$y_origin);
 
104
 
 
105
  $self->_draw_scale($gd,$scale,$min_score,$max_score,$dx,$dy,$y_origin);
 
106
  $self->draw_label(@_)       if $self->option('label');
 
107
  $self->draw_description(@_) if $self->option('description');
 
108
}
 
109
 
 
110
sub lookup_draw_method {
 
111
  my $self = shift;
 
112
  my $type = shift;
 
113
 
 
114
  return '_draw_histogram'            if $type eq 'histogram';
 
115
  return '_draw_boxes'                if $type eq 'boxes';
 
116
  return '_draw_line'                 if $type eq 'line'   or $type eq 'linepoints';
 
117
  return '_draw_points'               if $type eq 'points' or $type eq 'linepoints';
 
118
}
 
119
 
 
120
sub score {
 
121
  my $self    = shift;
 
122
  my $s       = $self->option('score');
 
123
  return $s   if defined $s;
 
124
  return eval { $self->feature->score };
 
125
}
 
126
 
 
127
sub score2position {
 
128
  my $self  = shift;
 
129
  my $score = shift;
 
130
 
 
131
  return unless defined $score;
 
132
 
 
133
  if ($self->{_clip_ok} && $score < $self->{_min_score}) {
 
134
    return $self->{_bottom};
 
135
  }
 
136
 
 
137
  elsif ($self->{_clip_ok} && $score > $self->{_max_score}) {
 
138
    return $self->{_top};
 
139
  }
 
140
 
 
141
  else {
 
142
    my $position      = ($score-$self->{_min_score}) * $self->{_scale};
 
143
    return $self->{_bottom} - $position;
 
144
  }
65
145
}
66
146
 
67
147
sub log10 { log(shift)/log(10) }
68
148
sub max10 {
69
149
  my $a = shift;
70
 
  $a = 1 if $a <= 0;
71
 
  my $l=int(log10($a)); 
 
150
  return 0 if $a==0;
 
151
  return -min10(-$a) if $a<0;
 
152
  return max10($a*10)/10 if $a < 1;
 
153
  
 
154
  my $l=int(log10($a));
72
155
  $l = 10**$l; 
73
 
  my $r = $a/$l; 
 
156
  my $r = $a/$l;
74
157
  return $r*$l if int($r) == $r;
75
158
  return $l*int(($a+$l)/$l);
76
159
}
77
160
sub min10 {
78
161
  my $a = shift;
79
 
  $a = 1 if $a <= 0;
 
162
  return 0 if $a==0;
 
163
  return -max10(-$a) if $a<0;
 
164
  return min10($a*10)/10 if $a < 1;
 
165
  
80
166
  my $l=int(log10($a));
81
167
  $l = 10**$l; 
82
168
  my $r = $a/$l; 
115
201
  my ($x3,$y3,$x4,$y4) = $parts[-1]->calculate_boundaries($left,$top);
116
202
  $gd->line($x4,$parts[-1]->{_y_position},$x4,$y4,$fgcolor);
117
203
 
118
 
  # from left to right  -- don't like this
119
 
  # $gd->line($x1,$y2,$x4,$y4,$fgcolor);
120
 
 
121
204
  # That's it.  Not too hard.
122
205
}
123
206
 
124
207
sub _draw_boxes {
125
208
  my $self = shift;
126
 
  my ($gd,$left,$top) = @_;
127
 
 
128
 
  my @parts  = $self->parts;
129
 
  my $fgcolor = $self->fgcolor;
130
 
  my $bgcolor = $self->bgcolor;
131
 
  my $height  = $self->height;
 
209
  my ($gd,$left,$top,$y_origin) = @_;
 
210
 
 
211
  my @parts    = $self->parts;
 
212
  my $fgcolor  = $self->fgcolor;
 
213
  my $bgcolor  = $self->bgcolor;
 
214
  my $lw       = $self->linewidth;
 
215
  my $negative = $self->color('neg_color') || $bgcolor;
 
216
  my $height   = $self->height;
 
217
 
 
218
  my $partcolor = $self->code_option('part_color');
 
219
  my $factory  = $self->factory;
132
220
 
133
221
  # draw each of the component lines of the histogram surface
134
222
  for (my $i = 0; $i < @parts; $i++) {
 
223
 
135
224
    my $part = $parts[$i];
136
225
    my $next = $parts[$i+1];
137
 
    my ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
138
 
    $self->filled_box($gd,$x1,$part->{_y_position},$x2,$y2,$bgcolor,$fgcolor);
139
 
    next unless $next;
140
 
    my ($x3,$y3,$x4,$y4) = $next->calculate_boundaries($left,$top);
141
 
    $gd->line($x2,$y2,$x3,$y4,$fgcolor) if $x2 < $x3;
 
226
 
 
227
    my ($color,$negcolor);
 
228
 
 
229
    # special check here for the part_color being defined so as not to introduce lots of
 
230
    # checking overhead when it isn't
 
231
    if ($partcolor) {
 
232
      $color    = $factory->translate_color($factory->option($part,'part_color',0,0));
 
233
      $negcolor = $color;
 
234
    } else {
 
235
      $color    = $bgcolor;
 
236
      $negcolor = $negative;
 
237
    }
 
238
 
 
239
    # my ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
 
240
    my ($x1,$x2) = ($left+$part->{left},$left+$part->{left}+$part->{width}-1);
 
241
    if ($part->{_y_position} < $y_origin) {
 
242
      $self->filled_box($gd,$x1,$part->{_y_position},$x2,$y_origin,$color,$fgcolor,$lw);
 
243
    } else {
 
244
      $self->filled_box($gd,$x1,$y_origin,$x2,$part->{_y_position},$negcolor,$fgcolor,$lw);
 
245
    }
142
246
  }
143
247
 
144
248
  # That's it.
159
263
  my $current_y = $first_part->{_y_position};
160
264
 
161
265
  for my $part (@parts) {
162
 
    my ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
 
266
    my ($x1,$x2) = ($left+$part->{left},$left+$part->{left}+$part->{width}-1);
163
267
    my $next_x = ($x1+$x2)/2;
164
268
    my $next_y = $part->{_y_position};
165
269
    $gd->line($current_x,$current_y,$next_x,$next_y,$fgcolor);
178
282
  my $bgcolor = $self->bgcolor;
179
283
  my $pr      = $self->point_radius;
180
284
 
 
285
  my $partcolor = $self->code_option('part_color');
 
286
  my $factory  = $self->factory;
 
287
 
181
288
  for my $part (@parts) {
182
 
    my ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
 
289
    my ($x1,$x2) = ($left+$part->{left},$left+$part->{left}+$part->{width}-1);
183
290
    my $x = ($x1+$x2)/2;
184
291
    my $y = $part->{_y_position};
185
 
    $symbol_ref->($gd,$x,$y,$pr,$bgcolor);
 
292
 
 
293
    my $color;
 
294
    if ($partcolor) {
 
295
      $color    = $factory->translate_color($factory->option($part,'part_color',0,0));
 
296
    } else {
 
297
      $color    = $bgcolor;
 
298
    }
 
299
 
 
300
    $symbol_ref->($gd,$x,$y,$pr,$color);
186
301
  }
187
302
}
188
303
 
 
304
sub _determine_side
 
305
{
 
306
  my $self = shift;
 
307
  my $side = $self->option('scale');
 
308
  return if $side eq 'none';
 
309
  $side   ||= $self->default_scale();
 
310
  return $side;
 
311
}
 
312
 
189
313
sub _draw_scale {
190
314
  my $self = shift;
191
 
  my ($gd,$scale,$min,$max,$dx,$dy) = @_;
 
315
  my ($gd,$scale,$min,$max,$dx,$dy,$y_origin) = @_;
192
316
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($dx,$dy);
193
317
 
194
 
  my $side = $self->option('scale');
195
 
  return if $side eq 'none';
196
 
  $side   ||= 'both';
 
318
  $y2 -= $self->pad_bottom - 1;
 
319
 
 
320
  my $side = $self->_determine_side();
197
321
 
198
322
  my $fg    = $self->fgcolor;
199
 
  my $half  = ($y1+$y2)/2;
200
323
  my $font  = $self->font('gdTinyFont');
201
324
 
202
325
  $gd->line($x1,$y1,$x1,$y2,$fg) if $side eq 'left'  || $side eq 'both';
203
326
  $gd->line($x2,$y1,$x2,$y2,$fg) if $side eq 'right' || $side eq 'both';
204
327
 
205
 
  for ([$y1,$max],[$half,int(($max-$min)/2+0.5)]) {
 
328
  $gd->line($x1,$y_origin,$x2,$y_origin,$fg);
 
329
 
 
330
  my @points = ([$y1,$max],[($y1+$y2)/2,($min+$max)/2],[$y2,$min]);
 
331
  push @points,[$y_origin,0] if ($min < 0 && $max > 0);
 
332
 
 
333
  my $last_font_pos = -99999999999;
 
334
 
 
335
  for (@points) {
206
336
    $gd->line($x1-3,$_->[0],$x1,$_->[0],$fg) if $side eq 'left'  || $side eq 'both';
207
337
    $gd->line($x2,$_->[0],$x2+3,$_->[0],$fg) if $side eq 'right' || $side eq 'both';
 
338
 
 
339
    my $font_pos = $_->[0]-($font->height/2);
 
340
 
 
341
    next unless $font_pos > $last_font_pos + $font->height; # prevent labels from clashing
208
342
    if ($side eq 'left' or $side eq 'both') {
209
 
      #      $gd->string(gdTinyFont,
210
 
      #           $x1 - gdTinyFont->width * length($_->[1]) - 3,$_->[0]-(gdTinyFont->height/3),
211
 
      #           $_->[1],
212
 
      #           $fg);
213
 
     $gd->string($font,
214
 
                  $x1 - $font->width * length($_->[1]) - 3,$_->[0]-($font->height/3),
 
343
      $gd->string($font,
 
344
                  $x1 - $font->width * length($_->[1]) - 3,$font_pos,
215
345
                  $_->[1],
216
346
                  $fg);
217
347
    }
218
348
    if ($side eq 'right' or $side eq 'both') {
219
 
#      $gd->string(gdTinyFont,
220
 
#                 $x2 + 4,$_->[0]-(gdTinyFont->height/3),
221
 
#                 $_->[1],
222
 
#                 $fg);
223
349
      $gd->string($font,
224
 
                  $x2 + 4,$_->[0]-($font->height/3),
 
350
                  $x2 + 5,$font_pos,
225
351
                  $_->[1],
226
352
                  $fg);
227
353
    }
 
354
    $last_font_pos = $font_pos;
228
355
  }
229
356
}
230
357
 
246
373
 
247
374
sub draw_triangle {
248
375
  my ($gd,$x,$y,$pr,$color) = @_;
 
376
  $pr /= 2;
249
377
  my ($vx1,$vy1) = ($x-$pr,$y+$pr);
250
378
  my ($vx2,$vy2) = ($x,  $y-$pr);
251
379
  my ($vx3,$vy3) = ($x+$pr,$y+$pr);
255
383
}
256
384
sub draw_square {
257
385
  my ($gd,$x,$y,$pr,$color) = @_;
 
386
  $pr /= 2;
258
387
  $gd->line($x-$pr,$y-$pr,$x+$pr,$y-$pr,$color);
259
388
  $gd->line($x+$pr,$y-$pr,$x+$pr,$y+$pr,$color);
260
389
  $gd->line($x+$pr,$y+$pr,$x-$pr,$y+$pr,$color);
269
398
  $gd->setPixel($x,$y,$color);
270
399
}
271
400
 
272
 
sub _subseq {
273
 
  my $class   = shift;
274
 
  my $feature = shift;
275
 
  return $feature->segments                if $feature->can('segments');
276
 
  my @split = eval { my $id   = $feature->location->seq_id;
277
 
                     my @subs = $feature->location->sub_Location;
278
 
                     grep {$id eq $_->seq_id} @subs};
279
 
  return @split if @split;
280
 
  return $feature->sub_SeqFeature          if $feature->can('sub_SeqFeature');
281
 
  return;
282
 
}
283
 
 
284
401
sub keyglyph {
285
402
  my $self = shift;
286
403
 
350
467
  my $segment  = $db->segment('Chr1');
351
468
  my @features = $segment->features('repeat_density');
352
469
 
353
 
  my $panel = Bio::Graphics::Panel->new;
 
470
  my $panel = Bio::Graphics::Panel->new(-pad_left=>40,-pad_right=>40);
354
471
  $panel->add_track(\@features,
355
 
                    -glyph => 'xyplot');
 
472
                    -glyph => 'xyplot',
 
473
                    -graph_type=>'points',
 
474
                    -point_symbol=>'disc',
 
475
                    -point_radius=>4,
 
476
                    -scale=>'both',
 
477
                    -height=>200,
 
478
  );
356
479
 
357
480
If you are using Generic Genome Browser, you will add this to the
358
481
configuration file:
360
483
  aggregators = repeat_density{density:repeat}
361
484
                clone alignment etc
362
485
 
 
486
Note that it is a good idea to add some padding to the left and right
 
487
of the panel; otherwise the scale will be partially cut off by the
 
488
edge of the image.
 
489
 
363
490
=head2 OPTIONS
364
491
 
365
492
The following options are standard among all Glyphs.  See
409
536
                "triangle", "square", "disc",
410
537
                "point", and "none".
411
538
 
412
 
  -point_radius Radius of the symbol, in      1
413
 
                pixels
 
539
  -point_radius Radius of the symbol, in      4
 
540
                pixels (does not apply
 
541
                to "point")
414
542
 
415
543
  -scale        Position where the Y axis     none
416
544
                scale is drawn if any.
420
548
  -graph_height Specify height of the graph   Same as the
421
549
                                              "height" option.
422
550
 
 
551
  -neg_color   For boxes only, bgcolor for    Same as bgcolor
 
552
               points with negative scores
 
553
 
 
554
  -part_color  For boxes & points only,       none
 
555
               bgcolor of each part (should
 
556
               be a callback). Supersedes
 
557
               -neg_color.
 
558
 
 
559
  -clip        If min_score and/or max_score  false
 
560
               are manually specified, then
 
561
               setting this to true will
 
562
               cause values outside the
 
563
               range to be clipped.
 
564
 
423
565
Note that when drawing scales on the left or right that the scale is
424
566
actually drawn a few pixels B<outside> the boundaries of the glyph.
425
567
You may wish to add some padding to the image using -pad_left and
426
568
-pad_right when you create the panel.
427
569
 
 
570
The B<-part_color> option can be used to color each part of the
 
571
graph. Only the "boxes", "points" and "linepoints" styles are
 
572
affected by this.  Here's a simple example:
 
573
 
 
574
  $panel->add_track->(\@affymetrix_data,
 
575
                      -glyph      => 'xyplot',
 
576
                      -graph_type => 'boxes',
 
577
                      -part_color => sub {
 
578
                                   my $score = shift->score;
 
579
                                   return 'red' if $score < 0;
 
580
                                   return 'lightblue' if $score < 500;
 
581
                                   return 'blue'      if $score >= 500;
 
582
                                  }
 
583
                      );
 
584
 
 
585
=head2 METHODS
 
586
 
 
587
For those developers wishing to derive new modules based on this
 
588
glyph, the main method to override is:
 
589
 
 
590
=over 4
 
591
 
 
592
=item 'method_name' = $glyph-E<gt>lookup_draw_method($type)
 
593
 
 
594
This method accepts the name of a graph type (such as 'histogram') and
 
595
returns the name of a method that will be called to draw the contents
 
596
of the graph, for example '_draw_histogram'. This method will be
 
597
called with three arguments:
 
598
 
 
599
   $self->$draw_method($gd,$left,$top,$y_origin)
 
600
 
 
601
where $gd is the GD object, $left and $top are the left and right
 
602
positions of the whole glyph (which includes the scale and label), and
 
603
$y_origin is the position of the zero value on the y axis (in
 
604
pixels). By the time this method is called, the y axis and labels will
 
605
already have been drawn, and the scale of the drawing (in pixels per
 
606
unit score) will have been calculated and stored in
 
607
$self-E<gt>{_scale}. The y position (in pixels) of each point to graph
 
608
will have been stored into the part, as $part-E<gt>{_y_position}. Hence
 
609
you could draw a simple scatter plot with this code:
 
610
 
 
611
 sub lookup_draw_method {
 
612
    my $self = shift;
 
613
    my $type = shift;
 
614
    if ($type eq 'simple_scatterplot') {
 
615
      return 'draw_points';
 
616
    } else {
 
617
      return $self->SUPER::lookup_draw_method($type);
 
618
    }
 
619
 }
 
620
 
 
621
 sub draw_points {
 
622
  my $self = shift;
 
623
  my ($gd,$left,$top) = @_;
 
624
  my @parts   = $self->parts;
 
625
  my $bgcolor = $self->bgcolor;
 
626
 
 
627
  for my $part (@parts) {
 
628
    my ($x1,$y1,$x2,$y2) = $part->calculate_boundaries($left,$top);
 
629
    my $x = ($x1+$x2)/2;  # take center
 
630
    my $y = $part->{_y_position};
 
631
    $gd->setPixel($x,$y,$bgcolor);
 
632
 }
 
633
 
 
634
=item $y_position = $self-E<gt>score2position($score)
 
635
 
 
636
Translate a score into a y pixel position, obeying clipping rules and
 
637
min and max values.
 
638
 
 
639
=back
 
640
 
428
641
=head1 BUGS
429
642
 
430
643
Please report them.