Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

executable file 348 lines (304 sloc) 8.618 kb
#!/usr/bin/perl
use strict;
use Getopt::Long;
use File::Spec;
use IO::Dir;
use Bio::Graphics::Panel;
use Bio::Graphics::Feature;
use File::Temp 'tempfile';
use Bio::Graphics::Wiggle;
my $MANUAL = 0;
my $POD = 0;
my $LIST = 0;
my $PICT = 0;
my $VIEW = 0;
my $BOXES = 0;
my $SVG = 0;
my $usage = <<USAGE;
Usage: $0 [options] glyph_type
Give usage information about Bio::Graphics glyphs.
Options:
-m --manual Print the full manual page for the glyph, followed
by a summary of its options.
-r --raw Print the quick summary of the glyph\'s options in raw POD
format.
-l --list List all glyphs that are available for use.
-p --picture Create a PNG picture of what the indicated glyph looks like.
The PNG will be written to stdout
-v --view Launch a viewer ("xv", "display" or "firefox") to show the
glyph.
-b --boxes Outline the boxes around each glyph
--svg When used in conjunction with --picture, will create
an SVG rather than a png using GD::SVG
If neither -m nor -l are specified, the default is to print a summary
of the glyph\'s options.
To experiment with glyph options, invoke $0 this way:
$0 -v glyph_name -- -option1 value1 -option2 value2
example:
$0 -v christmas_arrow -- -radius 5 -fgcolor green
USAGE
GetOptions ('manual' => \$MANUAL,
'raw' => \$POD,
'list' => \$LIST,
'picture' => \$PICT,
'view' => \$VIEW,
'boxes' => \$BOXES,
'svg' => \$SVG,
) or die $usage;
my $glyph = shift;
$glyph || $LIST or die $usage;
if ($LIST) {
print_list();
exit 0;
}
my $class = "Bio::Graphics::Glyph::$glyph";
unless (eval "require $class;1") {
my $mesg = $@;
$mesg =~ s/\(.+$//;
$mesg =~ s/at \(eval.+$//;
$mesg =~ s/\s+$//s;
warn $mesg,".\n";
die "Please run $0 -l for a list of valid glyphs.\n";
}
if ($PICT || $VIEW) {
print_picture($glyph,$VIEW,$SVG);
exit 0;
}
if ($MANUAL) {
system "perldoc",$class;
} elsif ($POD) {
print $class->options_pod();
} else {
print $class->options_man();
}
exit 0;
sub print_list {
my %glyphs;
for my $inc (@INC) {
my $dir = File::Spec->catfile($inc,'Bio','Graphics','Glyph');
next unless -d $dir;
my $d = IO::Dir->new($dir) or die "Couldn't open $dir for reading: $!";
while (defined(my $entry = $d->read)) {
next unless $entry =~ /\.pm$/;
(my $base = $entry) =~ s/\.pm$//;
eval "use Bio::Graphics::Glyph::$base";
next unless "Bio::Graphics::Glyph::$base"->isa('Bio::Graphics::Glyph');
my $f = File::Spec->catfile($dir,$entry);
my $io = IO::File->new($f) or next;
while (<$io>) {
chomp;
next unless /^=head1 NAME/../=head1 (SYNOPSIS|DESCRIPTION)/;
my ($name,$description) = /^Bio::Graphics::Glyph::(\w+)\s+(.+)/ or next;
$description =~ s/^[\s-]+//;
next if $description =~ /base class/;
$glyphs{$name} = $description;
}
}
}
for my $name (sort keys %glyphs) {
my $description = $glyphs{$name};
printf "%-20s %s\n",$name,$description;
}
exit 0;
}
sub print_picture {
my $glyph = shift;
my $viewit = shift;
my $svg = shift;
my $panel = Bio::Graphics::Panel->new(-length => 500,
-width => 250,
-pad_left => 20,
-pad_right => 20,
-pad_top => 10,
-pad_bottom => 10,
-key_style => 'between',
-truecolor => 1,
-image_class => $svg ?
'GD::SVG' : 'GD'
);
my @additional_args = @ARGV;
my $sort_order = sub ($$) {
my ($g1,$g2) = @_;
return $g1->feature->display_name cmp $g2->feature->display_name;
};
my @track_args = (
-glyph => $glyph,
-label => 1,
-description => 1,
-height => 16,
-sort_order => $sort_order,
@additional_args
);
my $class = "Bio::Graphics::Glyph::$glyph";
eval "require $class";
warn $@ if $@;
my @example_features = eval{$class->demo_feature};
warn $@ if $@;
if (@example_features) {
$panel->add_track(
\@example_features,
@track_args,
-key => 'Demo feature provided by glyph',
);
} else {
create_tracks($panel,$glyph,\@track_args);
}
if ($BOXES) {
my $gd = $panel->gd;
my $boxes = $panel->boxes;
for my $box (@$boxes) {
my ($f,$x1,$y1,$x2,$y2) = @$box;
my $red = $panel->translate_color('red');
$gd->rectangle($x1,$y1,$x2,$y2,$red);
}
}
my $png = $svg ? $panel->svg : $panel->png;
unless ($viewit) {
print $png;
return;
}
# special stuff for displaying on linux systems
for my $viewer (qw(xv display)) { # can read from stdin
$ENV{SHELL} && `which $viewer` or next;
my $child = open my $fh,"|-";
if ($child) {
print $fh $png;
close $fh;
return;
} else {
fork() && exit 0;
exec $viewer,'-';
}
}
# if we get here, then launch firefox
my ($fh,$filename) = tempfile(SUFFIX=>'.png',
UNLINK=>1,
);
print $fh $png;
close $fh;
my $child = fork() && sleep 2 && exit 0;
exec 'firefox',$filename;
}
sub create_tracks {
my ($panel,$glyph,$args) = @_;
# the next bit of code is here to manufacture some wiggle data for demo purposes
my $wig = Bio::Graphics::Wiggle->new(undef,
1,
{seqid=>'chr1',
start=>1,
end =>500}
);
my @values = map {
(sin($_/60)+sin($_/12))*100+rand(100)
} 1..500;
if (eval "require Statistics::Descriptive; 1") {
my $stat = Statistics::Descriptive::Sparse->new;
$stat->add_data(@values);
$wig->min($stat->min);
$wig->max($stat->max);
$wig->mean($stat->mean);
$wig->stdev($stat->standard_deviation);
} else {
my $min = $values[0];
my $max = $values[0];
my $tot = 0;
for (@values) {$min = $_ if $min > $_;
$max = $_ if $max < $_;
$tot += $_;
}
$wig->min($min);
$wig->max($max);
$wig->stdev(120); # just make it up
$wig->mean($tot/@values);
}
$wig->set_value($_=>$values[$_-1]) for(1..500);
my $f0 = Bio::Graphics::Feature->new(-start => 1,
-end => 30,
-score => 10,
-strand=> +1,
-source => 'confirmed',
-type => 'UTR',
);
my $f1 = Bio::Graphics::Feature->new(-start => 31,
-end => 100,
-score => 20,
-strand=> +1,
-source => 'confirmed',
-type => 'CDS',
);
my $f2 = Bio::Graphics::Feature->new(-start => 200,
-end => 300,
-score => 30,
-strand=> +1,
-source=> 'unconfirmed',
-type => 'CDS',
);
my $f3 = Bio::Graphics::Feature->new(-start => 400,
-end => 450,
-score => 40,
-strand=> +1,
-source=> 'unconfirmed',
-type => 'CDS',
);
my $f4 = Bio::Graphics::Feature->new(-start => 451,
-end => 500,
-score => 50,
-strand=> +1,
-source=>'confirmed',
-type => 'UTR',
);
my $feature1 = Bio::Graphics::Feature->new(-type=>'mRNA',
-name=>'f1',
-desc=>'This is a one-level feature',
-strand=>+1,
-start=>1,
-end=>500,
-attributes=>{
wigfile=>$wig,
wigfileA=>$wig,
wigfileB=>$wig,
}
);
my $feature2 = Bio::Graphics::Feature->new(-type=>'mRNA',
-name=>'f2',
-desc=>'This is a two-level feature',
-strand=>+1,
-attributes=>{
wigfile=>$wig,
wigfileA=>$wig,
wigfileB=>$wig,
}
);
my $feature3 = Bio::Graphics::Feature->new(-type=>'mRNA',
-name=>'f3',
-desc=>'This is a two-level feature',
-strand=>+1,
-attributes=>{
wigfile=>$wig,
wigfileA=>$wig,
wigfileB=>$wig,
}
);
$feature2->add_SeqFeature($_) foreach ($f0,$f1,$f2,$f3,$f4);
$feature3->add_SeqFeature($_) foreach ($f0,$f1,$f3,$f4);
my $feature4 = Bio::Graphics::Feature->new(-type=>'gene',
-name=>'f4',
-desc=>'This is a three-level feature',
-attributes=>{
wigfile=>$wig,
wigfileA=>$wig,
wigfileB=>$wig,
}
);
$feature4->add_SeqFeature($feature2,$feature3);
$panel->add_track([$feature1,$feature2,$feature4],
@$args,
-key => 'No connector',
);
$panel->add_track([$feature1,$feature2,$feature4],
@$args,
-connector => 'dashed',
-key => 'Dashed connector',
);
}
1;
Jump to Line
Something went wrong with that request. Please try again.