view release on metacpan or  search on metacpan

t/BioGraphics.t  view on Meta::CPAN

$data->add_type(TEST=>{bgcolor=>'green',
		       feature=>'test_feature',
		       glyph => 'generic'});
is $data->setting(TEST=>'bgcolor'),'green';
is $data->setting(TEST=>'feature'),'test_feature';
$data->add_feature(Bio::Graphics::Feature->new(-seq_id    => 'chr1',
						   -start     => 1,
						   -end       => 1000,
						   -primary_tag=> 'test_feature'));
$data->add_feature(Bio::Graphics::Feature->new(-seq_id    => 'chr2',
						   -start     => 2,
						   -end       => 2000,
						   -primary_tag=> 'test_feature'));
$data->add_feature(Bio::Graphics::Feature->new(-seq_id    => 'chr3',
						   -start     => 3,
						   -end       => 3000),
		   'test_feature');
my @f = $data->features('test_feature');
is scalar @f,3;

# test FeatureBase
my $bfg   = 'Bio::Graphics::Feature';
$feature  = $bfg->new(-seq_id=>'chr2',-start=>201,-end=>300,-strand=>1);
is $feature->seq_id,'chr2';
is $feature->start,201;
is $feature->end,300;
is $feature->strand,1;

# plus strand feature, plus strand ref sequence
my $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;
is $feature->abs_start,201;
is $feature->abs_end,300;
is $feature->abs_strand,1;

# plus strand feature, minus strand ref sequence
$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;

# 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 }

t/BioGraphics.t  view on Meta::CPAN

				  -name=>'predicted2',
				  -type=>'exon',-desc=>'predicted');

  my $confirmed_exon3 = $ftr->new(-start=>150,-stop=>190,
				  -type=>'exon',-desc=>'confirmed',
				  -name=>'abc123');
  my $partial_gene = $ftr->new(-segments=>[$confirmed_exon1,$predicted_exon1,$predicted_exon2,$confirmed_exon3],
			       -name => 'partial gene',
			       -type => 'transcript',
			       -strand => 1,
			       -desc => '(from a big annotation pipeline)'
			    );
  my @segments = $partial_gene->segments;
  my $score = 10;
  foreach (@segments) {
    $_->score($score);
    $score += 10;
  }

  my $panel = Bio::Graphics::Panel->new(
					-gridcolor => 'lightcyan',
					-grid => 1,
					-segment => $segment,
					-spacing => 15,
					-width   => 600,
					-pad_top  => 20,
					-pad_bottom  => 20,
					-pad_left => 20,
					-pad_right=> 20,
					-key_style => 'between',
					-empty_tracks => 'suppress',
				       );
  my @colors = $panel->color_names();

  my $t = $panel->add_track(
			    transcript2 => [$abc3,$zed_27],
			    -label => 1,
			    -bump => 1,
			    -key => 'Prophecies',
			   );
  $t->configure(-bump=>1);
  $panel->add_track($segment,
		    -glyph => 'arrow',
		    -label => 'base pairs',
		    -double => 1,
		    -bump => 0,
		    -height => 10,
		    -arrowstyle=>'regular',
		    -linewidth=>1,
		    -tick => 2,
		   );
  $panel->unshift_track(generic => [$segment,$zk154_1,$zk154_2,$zk154_3,[$xyz4,$zed_27]],
			-label     => sub { my $feature = shift; $feature->sub_SeqFeature>0},
			-bgcolor   => sub { shift->primary_tag eq 'predicted' ? 'olive' : 'red'},
			-connector => sub { my $feature = shift;
					    my $type = $feature->primary_tag;
					    $type eq 'group'      ? 'dashed'
					      : $type eq 'transcript' ? 'hat'
						: $type eq 'alignment'  ? 'solid'
						  : undef},
			-all_callbacks => 1,
			-connector_color => 'black',
			-height => 10,
			-bump => 1,
			-linewidth=>2,
			-key => 'Signs',
			-empty_tracks => 'suppress',
		       );

  my $track = $panel->add_track(-glyph=> sub { shift->primary_tag =~ /transcript|alignment/ ? 'transcript2': 'generic'},
				-label   => sub { $_[-1]->level == 0 } ,
				-connector => sub { return shift->type eq 'group' ? 'dashed' : 'hat'},
				-point  => 0,
				-orient => 'N',
				-height => 8,
				-base => 1,
				-relative_coords => 1,
				-tick  => 2,
				-all_callbacks => 1,
				-bgcolor => 'red',
				-key     => 'Dynamically Added');
  $track->add_feature($bigone,$zed_27,$abc3);
  $track->add_group($predicted_exon1,$predicted_exon2,$confirmed_exon3);

  $panel->add_track(
		    [$abc3,$zed_27,$partial_gene],
		    -bgcolor   => sub { shift->source_tag eq 'predicted' ? 'green' : 'blue'},
		    -glyph   => 'transcript',
		    -label       => sub { shift->sub_SeqFeature > 0 },
		    -description => sub {
		      my $feature = shift;
		      return 1   if $feature->primary_tag eq 'transcript';
		      return '*' if $feature->source_tag eq 'predicted';
		      return;
		    },
		    -font2color  => 'red',
		    -bump => +1,
		    -key => 'Portents',
		   );
  $panel->add_track(segments => [$segment,$zk154_1,[$zk154_2,$xyz4]],
		    -label     => 1,
		    -bgcolor   => sub { shift->primary_tag eq 'predicted' ? 'green' : 'blue'},
		    -connector => sub { my $primary_tag = shift->primary_tag;
					$primary_tag eq 'transcript' ? 'hat'
					  : $primary_tag eq 'alignment'  ? 'solid'
					    : undef},
		    -connector_color => 'black',
		    -height => 10,
		    -bump => 1,
		    -key => 'Signals',
		   );
  $panel->add_track(generic => [],
		    -key => 'Empty');

  $panel->add_track(graded_segments => $partial_gene,
		    -bgcolor =>'blue',
		    -vary_fg => 1,
		    -label   => 1,
		    -key     => 'Scored thing');

  $panel->add_track(diamond => [$segment,$zk154_1,$zk154_2,$zk154_3,$xyz4,$zed_27],
		    -bgcolor =>'blue',
		    -label   => 1,
		    -key     => 'pointy thing');
  return $panel;
}

sub t3 {
  my $data  = Bio::Graphics::FeatureFile->new(-file => 
					      File::Spec->catfile($Bin,'data','feature_data.txt')
      ) or die;
  my ($tracks,$panel) = $data->render;
  return $panel;
}