1# -*-Perl-*- Test Harness script for Bioperl
2
3use strict;
4use File::Spec;
5use FindBin '$Bin';
6use File::Glob ':glob';
7
8# In order to properly run the image comparison tests the images may need to be
9# regenerated from scratch; this is primarily due to changes in GD versions, OS,
10# Bio::Graphics, problems with storing binary data in CVS, etc.
11
12# We'll need to reconfigure these tests to allow do_write()
13# the ability to regenerate those files when passing the --write option
14
15# for now, the image tests are turned off
16use lib "$Bin/../lib";
17
18# libgd has become unstable -- produces a binary different (but visually identical)
19# image each time.
20use constant IMAGE_TESTS => 0;
21
22BEGIN {
23  use lib '.';
24  use Test::More tests => 49 + (IMAGE_TESTS ? 3 : 0);
25  use_ok('GD::Image');
26  use_ok('Bio::Graphics::FeatureFile');
27  use_ok('Bio::Graphics::Panel');
28}
29
30my $images = File::Spec->catfile($Bin,'data');
31
32my @images = IMAGE_TESTS ? qw(t1 t2 t3) : ();
33
34# parse command line arguments
35my $write = 0;
36while (@ARGV && $ARGV[0] =~ /^--?(\w+)/) {
37  my $arg = $1;
38  if ($arg eq 'write') {
39    warn "Writing regression test images into ",$images,".........\n";
40    $write++;
41  }
42  shift;
43}
44
45foreach (@images) {
46  if ($write) { warn "$_...\n"; do_write($_) } else { eval { do_compare($_) } }
47}
48
49my $data  = Bio::Graphics::FeatureFile->new(-file => File::Spec->catfile($Bin,'data','feature_data.txt'),
50					    -safe => 0,
51    ) or die;
52ok defined $data;
53is $data->render, 5;
54is $data->setting(general=>'pixels'), 750;
55is $data->setting('general'), 3;
56is $data->setting, 6;
57is $data->glyph('EST'), 'segments';
58
59my %style = $data->style('EST');
60is $style{-connector}, 'solid';
61is $style{-height}, 5;
62is $style{-bgcolor}, 'yellow';
63
64is $data->configured_types, 5;
65is @{$data->features('EST')}, 5;
66
67my $thing = $data->features('EST');
68is $thing->[0]->seq_id,'B0511';
69
70my ($feature) = grep {$_->name eq 'Predicted gene 1'} @{$data->features('FGENESH')};
71ok $feature;
72is $feature->desc, "Pfam";
73is $feature->score, 20;
74
75# test handling of things that look like comments
76is $data->setting(EST=>'bgcolor'),'yellow';
77is $data->setting(EST=>'fgcolor'),'#EE00FF';
78is $data->setting(EST=>'link'),'http://www.google.com/search?q=$name#results';
79
80# test handling of adding features
81$data->add_type(TEST=>{bgcolor=>'green',
82		       feature=>'test_feature',
83		       glyph => 'generic'});
84is $data->setting(TEST=>'bgcolor'),'green';
85is $data->setting(TEST=>'feature'),'test_feature';
86$data->add_feature(Bio::Graphics::Feature->new(-seq_id    => 'chr1',
87						   -start     => 1,
88						   -end       => 1000,
89						   -primary_tag=> 'test_feature'));
90$data->add_feature(Bio::Graphics::Feature->new(-seq_id    => 'chr2',
91						   -start     => 2,
92						   -end       => 2000,
93						   -primary_tag=> 'test_feature'));
94$data->add_feature(Bio::Graphics::Feature->new(-seq_id    => 'chr3',
95						   -start     => 3,
96						   -end       => 3000),
97		   'test_feature');
98my @f = $data->features('test_feature');
99is scalar @f,3;
100
101# test FeatureBase
102my $bfg   = 'Bio::Graphics::Feature';
103$feature  = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>1);
104is $feature->seq_id,'chr2';
105is $feature->start,201;
106is $feature->end,300;
107is $feature->strand,1;
108
109# plus strand feature, plus strand ref sequence
110my $ref   = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>1);
111$feature->refseq($ref);
112is $feature->start,1;
113is $feature->end,100;
114is $feature->strand,1;
115is $feature->abs_start,201;
116is $feature->abs_end,300;
117is $feature->abs_strand,1;
118
119# plus strand feature, minus strand ref sequence
120$ref      = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>-1);
121$feature->refseq($ref);
122is $feature->start,100;   # expect flipping so that start > end
123is $feature->end,1;
124is $feature->strand,-1;
125
126# minus strand feature, plus strand ref
127$feature = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>-1);
128$ref   = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>1);
129$feature->refseq($ref);
130is $feature->start,1;
131is $feature->end,100;
132is $feature->strand,-1;
133
134# minus strand feature, minus strand ref
135$ref      = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>-1);
136$feature->refseq($ref);
137is $feature->start,100;   # expect flipping so that start > end
138is $feature->end,1;
139is $feature->strand,1;
140
141# test safety of callbacks
142is $data->safe,0;
143is ref $data->setting(SwissProt=>'fill'),'';
144is eval{ref $data->code_setting(SwissProt=>'fill')},undef;
145
146$data  = Bio::Graphics::FeatureFile->new(-file => File::Spec->catfile($Bin,'data', 'feature_data.txt'),
147					 -safe => 1,
148    ) or die;
149
150is $data->safe,1;
151is ref $data->setting(SwissProt=>'fill'),'CODE';
152is eval{ref $data->code_setting(SwissProt=>'fill')},'CODE';
153
154exit 0;
155
156sub do_write {
157  my $test = shift;
158  my $canpng = GD::Image->can('png');
159  my $cangif = GD::Image->can('gif');
160  my $test_sub    = $test;
161  if ($canpng) {
162    my $output_file = File::Spec->catfile($Bin,'data',$test).'.png';
163    my $panel       = eval "$test_sub()" or die "Couldn't run test: $@";
164    open OUT,">$output_file" or die "Couldn't open $output_file for writing: $!";
165    print OUT $panel->gd->png;
166    close OUT;
167  }
168  if ($cangif) {
169    my $output_file = File::Spec->catfile($Bin,'data',$test).'.gif';
170    my $panel       = eval "$test_sub()" or die "Couldn't run test: $@";
171    open OUT,">$output_file" or die "Couldn't open $output_file for writing: $!";
172    print OUT $panel->gd->gif;
173    close OUT;
174  }
175}
176
177sub do_compare {
178  my $test = shift;
179  my $cangif = GD::Image->can('gif');
180  my @input_files = glob($images . ($cangif ? "/$test/*.gif" : "/$test/*.png"));
181  my $test_sub    = $test;
182  my $panel       = eval "$test_sub()" or die "Couldn't run test";
183  my $ok = 0;
184  my $test_data = $cangif ? $panel->gd->gif : $panel->gd->png;
185  foreach (@input_files) {
186      my $gd = $cangif ? GD::Image->newFromGif($_) : GD::Image->newFromPng($_);
187      my $reference_data = $cangif ? $gd->gif : $gd->png;
188      if ($reference_data eq $test_data) {
189	  $ok++;
190	  last;
191      }
192  }
193  ok($ok);
194}
195
196sub read_file {
197  my $f = shift;
198  open F,$f or die "Can't open $f: $!";
199  binmode(F);
200  my $data = '';
201  while (read(F,$data,1024,length $data)) { 1 }
202  close F;
203  $data;
204}
205
206
207sub t1 {
208
209  my $ftr = 'Bio::Graphics::Feature';
210
211  my $segment = $ftr->new(-start=>1,-end=>1000,-name=>'ZK154',-type=>'clone');
212  my $subseg1 = $ftr->new(-start=>1,-end=>500,-name=>'seg1',-type=>'gene');
213  my $subseg2 = $ftr->new(-start=>250,-end=>500,-name=>'seg2',-type=>'gene');
214  my $subseg3 = $ftr->new(-start=>250,-end=>500,-name=>'seg3',-type=>'gene');
215  my $subseg4 = $ftr->new(-start=>1,-end=>400,-name=>'seg4',-type=>'gene');
216  my $subseg5 = $ftr->new(-start=>400,-end=>800,-name=>'seg5',-type=>'gene');
217  my $subseg6 = $ftr->new(-start=>550,-end=>800,-name=>'seg6',-type=>'gene');
218  my $subseg7 = $ftr->new(-start=>550,-end=>800,-name=>'seg7',-type=>'gene');
219  my $subseg8 = $ftr->new(-segments=>[[100,200],[300,400],[420,800]],-name=>'seg8',-type=>'gene');
220
221  my $panel = Bio::Graphics::Panel->new(
222					-grid => 1,
223					-segment => $segment,
224					-key_style => 'bottom');
225  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
226			       $subseg5,$subseg6,$subseg7,$subseg8],
227		    -bump => 1,
228		    -label => 1,
229		    -key => '+1 bumping');
230  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
231			       $subseg5,$subseg6,$subseg7,$subseg8],
232		    -bump => -1,
233		    -label => 1,
234		    -bgcolor => 'blue',
235		    -key => '-1 bumping');
236  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
237			       $subseg5,$subseg6,$subseg7,$subseg8],
238		    -bump => +2,
239		    -label => 1,
240		    -bgcolor => 'orange',
241		    -key => '+2 bumping');
242  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
243			       $subseg5,$subseg6,$subseg7,$subseg8],
244		    -bump => -2,
245		    -label => 1,
246		    -bgcolor => 'yellow',
247		    -key => '-2 bumping');
248  return $panel;
249}
250
251
252sub t2 {
253  my $ftr = 'Bio::Graphics::Feature';
254
255  my $segment = $ftr->new(-start=>-100,-end=>1000,-name=>'ZK154',-type=>'clone');
256  my $zk154_1 = $ftr->new(-start=>-50,-end=>800,-name=>'ZK154.1',-type=>'gene');
257  my $zk154_2 = $ftr->new(-start=>380,-end=>500,-name=>'ZK154.2',-type=>'gene');
258  my $zk154_3 = $ftr->new(-start=>900,-end=>1200,-name=>'ZK154.3',-type=>'gene');
259
260  my $zed_27 = $ftr->new(-segments=>[[400,500],[550,600],[800,950]],
261			 -name=>'zed-27',
262			 -strand => 1,
263			 -subtype=>'exon',-type=>'transcript');
264  my $abc3 = $ftr->new(-segments=>[[100,200],[350,400],[500,550]],
265		       -name=>'abc53',
266		       -strand => -1,
267		       -subtype=>'exon',-type=>'transcript');
268  my $xyz4 = $ftr->new(-segments=>[[40,80],[100,120],[200,280],[300,320]],
269		       -name=>'xyz4',
270		       -subtype=>'predicted',-type=>'alignment');
271
272  my $m3 = $ftr->new(-segments=>[[20,40],[30,60],[90,270],[290,300]],
273		     -name=>'M3',
274		     -subtype=>'predicted',-type=>'alignment');
275
276  my $bigone = $ftr->new(-segments=>[[-200,-120],[90,270],[290,300]],
277			 -name=>'big one',
278			 -strand => 1,
279			 -subtype=>'predicted',-type=>'alignment');
280
281  my $fred_12 = $ftr->new(-segments=>[$xyz4,$zed_27],
282			  -type => 'group',
283			  -name =>'fred-12');
284
285  my $confirmed_exon1 = $ftr->new(-start=>1,-stop=>20,
286				  -type=>'exon',
287				  -desc=>'confirmed',
288				  -name => 'confirmed1',
289				 );
290  my $predicted_exon1 = $ftr->new(-start=>30,-stop=>50,
291				  -type=>'exon',
292				  -name=>'predicted1',
293				  -desc=>'predicted');
294  my $predicted_exon2 = $ftr->new(-start=>60,-stop=>100,
295				  -name=>'predicted2',
296				  -type=>'exon',-desc=>'predicted');
297
298  my $confirmed_exon3 = $ftr->new(-start=>150,-stop=>190,
299				  -type=>'exon',-desc=>'confirmed',
300				  -name=>'abc123');
301  my $partial_gene = $ftr->new(-segments=>[$confirmed_exon1,$predicted_exon1,$predicted_exon2,$confirmed_exon3],
302			       -name => 'partial gene',
303			       -type => 'transcript',
304			       -strand => 1,
305			       -desc => '(from a big annotation pipeline)'
306			    );
307  my @segments = $partial_gene->segments;
308  my $score = 10;
309  foreach (@segments) {
310    $_->score($score);
311    $score += 10;
312  }
313
314  my $panel = Bio::Graphics::Panel->new(
315					-gridcolor => 'lightcyan',
316					-grid => 1,
317					-segment => $segment,
318					-spacing => 15,
319					-width   => 600,
320					-pad_top  => 20,
321					-pad_bottom  => 20,
322					-pad_left => 20,
323					-pad_right=> 20,
324					-key_style => 'between',
325					-empty_tracks => 'suppress',
326				       );
327  my @colors = $panel->color_names();
328
329  my $t = $panel->add_track(
330			    transcript2 => [$abc3,$zed_27],
331			    -label => 1,
332			    -bump => 1,
333			    -key => 'Prophecies',
334			   );
335  $t->configure(-bump=>1);
336  $panel->add_track($segment,
337		    -glyph => 'arrow',
338		    -label => 'base pairs',
339		    -double => 1,
340		    -bump => 0,
341		    -height => 10,
342		    -arrowstyle=>'regular',
343		    -linewidth=>1,
344		    -tick => 2,
345		   );
346  $panel->unshift_track(generic => [$segment,$zk154_1,$zk154_2,$zk154_3,[$xyz4,$zed_27]],
347			-label     => sub { my $feature = shift; $feature->sub_SeqFeature>0},
348			-bgcolor   => sub { shift->primary_tag eq 'predicted' ? 'olive' : 'red'},
349			-connector => sub { my $feature = shift;
350					    my $type = $feature->primary_tag;
351					    $type eq 'group'      ? 'dashed'
352					      : $type eq 'transcript' ? 'hat'
353						: $type eq 'alignment'  ? 'solid'
354						  : undef},
355			-all_callbacks => 1,
356			-connector_color => 'black',
357			-height => 10,
358			-bump => 1,
359			-linewidth=>2,
360			-key => 'Signs',
361			-empty_tracks => 'suppress',
362		       );
363
364  my $track = $panel->add_track(-glyph=> sub { shift->primary_tag =~ /transcript|alignment/ ? 'transcript2': 'generic'},
365				-label   => sub { $_[-1]->level == 0 } ,
366				-connector => sub { return shift->type eq 'group' ? 'dashed' : 'hat'},
367				-point  => 0,
368				-orient => 'N',
369				-height => 8,
370				-base => 1,
371				-relative_coords => 1,
372				-tick  => 2,
373				-all_callbacks => 1,
374				-bgcolor => 'red',
375				-key     => 'Dynamically Added');
376  $track->add_feature($bigone,$zed_27,$abc3);
377  $track->add_group($predicted_exon1,$predicted_exon2,$confirmed_exon3);
378
379  $panel->add_track(
380		    [$abc3,$zed_27,$partial_gene],
381		    -bgcolor   => sub { shift->source_tag eq 'predicted' ? 'green' : 'blue'},
382		    -glyph   => 'transcript',
383		    -label       => sub { shift->sub_SeqFeature > 0 },
384		    -description => sub {
385		      my $feature = shift;
386		      return 1   if $feature->primary_tag eq 'transcript';
387		      return '*' if $feature->source_tag eq 'predicted';
388		      return;
389		    },
390		    -font2color  => 'red',
391		    -bump => +1,
392		    -key => 'Portents',
393		   );
394  $panel->add_track(segments => [$segment,$zk154_1,[$zk154_2,$xyz4]],
395		    -label     => 1,
396		    -bgcolor   => sub { shift->primary_tag eq 'predicted' ? 'green' : 'blue'},
397		    -connector => sub { my $primary_tag = shift->primary_tag;
398					$primary_tag eq 'transcript' ? 'hat'
399					  : $primary_tag eq 'alignment'  ? 'solid'
400					    : undef},
401		    -connector_color => 'black',
402		    -height => 10,
403		    -bump => 1,
404		    -key => 'Signals',
405		   );
406  $panel->add_track(generic => [],
407		    -key => 'Empty');
408
409  $panel->add_track(graded_segments => $partial_gene,
410		    -bgcolor =>'blue',
411		    -vary_fg => 1,
412		    -label   => 1,
413		    -key     => 'Scored thing');
414
415  $panel->add_track(diamond => [$segment,$zk154_1,$zk154_2,$zk154_3,$xyz4,$zed_27],
416		    -bgcolor =>'blue',
417		    -label   => 1,
418		    -key     => 'pointy thing');
419  return $panel;
420}
421
422sub t3 {
423  my $data  = Bio::Graphics::FeatureFile->new(-file =>
424					      File::Spec->catfile($Bin,'data','feature_data.txt')
425      ) or die;
426  my ($tracks,$panel) = $data->render;
427  return $panel;
428}
429