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