view release on metacpan or  search on metacpan

t/BioGraphics.t  view on Meta::CPAN

# minus strand feature, plus strand ref
$feature = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>-1);
$ref   = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>1);
$feature->refseq($ref);
is $feature->start,1;
is $feature->end,100;
is $feature->strand,-1;

# minus strand feature, minus strand ref
$ref      = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>-1);
$feature->refseq($ref);
is $feature->start,100;   # expect flipping so that start > end
is $feature->end,1;
is $feature->strand,1;

# test safety of callbacks
is $data->safe,0;
is ref $data->setting(SwissProt=>'fill'),'';
is eval{ref $data->code_setting(SwissProt=>'fill')},undef;

$data  = Bio::Graphics::FeatureFile->new(-file => File::Spec->catfile($Bin,'data', 'feature_data.txt'),
					 -safe => 1,
    ) or die;

is $data->safe,1;
is ref $data->setting(SwissProt=>'fill'),'CODE';
is eval{ref $data->code_setting(SwissProt=>'fill')},'CODE';

exit 0;

sub do_write {
  my $test = shift;
  my $canpng = GD::Image->can('png');
  my $cangif = GD::Image->can('gif');
  my $test_sub    = $test;
  if ($canpng) {
    my $output_file = File::Spec->catfile($Bin,'data',$test).'.png';
    my $panel       = eval "$test_sub()" or die "Couldn't run test: $@";
    open OUT,">$output_file" or die "Couldn't open $output_file for writing: $!";
    print OUT $panel->gd->png;
    close OUT;
  }
  if ($cangif) {
    my $output_file = File::Spec->catfile($Bin,'data',$test).'.gif';
    my $panel       = eval "$test_sub()" or die "Couldn't run test: $@";
    open OUT,">$output_file" or die "Couldn't open $output_file for writing: $!";
    print OUT $panel->gd->gif;
    close OUT;
  }
}

sub do_compare {
  my $test = shift;
  my $cangif = GD::Image->can('gif');
  my @input_files = glob($images . ($cangif ? "/$test/*.gif" : "/$test/*.png"));
  my $test_sub    = $test;
  my $panel       = eval "$test_sub()" or die "Couldn't run test";
  my $ok = 0;
  my $test_data = $cangif ? $panel->gd->gif : $panel->gd->png;
  foreach (@input_files) {
      my $gd = $cangif ? GD::Image->newFromGif($_) : GD::Image->newFromPng($_);
      my $reference_data = $cangif ? $gd->gif : $gd->png;
      if ($reference_data eq $test_data) {
	  $ok++;
	  last;
      }
  }
  ok($ok);
}

sub read_file {
  my $f = shift;
  open F,$f or die "Can't open $f: $!";
  binmode(F);
  my $data = '';
  while (read(F,$data,1024,length $data)) { 1 }
  close F;
  $data;
}


sub t1 {

  my $ftr = 'Bio::Graphics::Feature';

  my $segment = $ftr->new(-start=>1,-end=>1000,-name=>'ZK154',-type=>'clone');
  my $subseg1 = $ftr->new(-start=>1,-end=>500,-name=>'seg1',-type=>'gene');
  my $subseg2 = $ftr->new(-start=>250,-end=>500,-name=>'seg2',-type=>'gene');
  my $subseg3 = $ftr->new(-start=>250,-end=>500,-name=>'seg3',-type=>'gene');
  my $subseg4 = $ftr->new(-start=>1,-end=>400,-name=>'seg4',-type=>'gene');
  my $subseg5 = $ftr->new(-start=>400,-end=>800,-name=>'seg5',-type=>'gene');
  my $subseg6 = $ftr->new(-start=>550,-end=>800,-name=>'seg6',-type=>'gene');
  my $subseg7 = $ftr->new(-start=>550,-end=>800,-name=>'seg7',-type=>'gene');
  my $subseg8 = $ftr->new(-segments=>[[100,200],[300,400],[420,800]],-name=>'seg8',-type=>'gene');

  my $panel = Bio::Graphics::Panel->new(
					-grid => 1,
					-segment => $segment,
					-key_style => 'bottom');
  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
			       $subseg5,$subseg6,$subseg7,$subseg8],
		    -bump => 1,
		    -label => 1,
		    -key => '+1 bumping');
  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
			       $subseg5,$subseg6,$subseg7,$subseg8],
		    -bump => -1,
		    -label => 1,
		    -bgcolor => 'blue',
		    -key => '-1 bumping');
  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
			       $subseg5,$subseg6,$subseg7,$subseg8],
		    -bump => +2,
		    -label => 1,
		    -bgcolor => 'orange',
		    -key => '+2 bumping');
  $panel->add_track(segments=>[$subseg1,$subseg2,$subseg3,$subseg4,
			       $subseg5,$subseg6,$subseg7,$subseg8],
		    -bump => -2,
		    -label => 1,
		    -bgcolor => 'yellow',