Bio-Graphics
view release on metacpan or search on metacpan
lib/Bio/Graphics/FeatureFile.pm view on Meta::CPAN
if exists $args{-map_coords} && ref($args{-map_coords}) eq 'CODE';
$self->smart_features($args{-smart_features}) if exists $args{-smart_features};
$self->{safe} = $args{-safe} if exists $args{-safe};
$self->safe_world(1) if $args{-safe_world};
$self->allow_whitespace(1) if $args{-allow_whitespace};
$self->init_parse();
# call with
# -file
# -text
if (my $file = $args{-file}) {
no strict 'refs';
if (defined fileno($file)) { # a filehandle
$self->parse_fh($file);
} elsif ($file eq '-') {
$self->parse_argv();
} else {
$self->parse_file($file);
}
} elsif (my $text = $args{-text}) {
$self->parse_text($text);
}
$self->finish_parse();
return $self;
}
=item $features = Bio::Graphics::FeatureFile-E<gt>new_from_cache(@args)
Like new() but caches the parsed file in /tmp/bio_graphics_ff_cache_*
(where * is the UID of the current user). This can speed up parsing
tremendously for files that have many includes.
Note that the presence of an #exec statement always invalidates the
cache and causes a full parse.
=cut
sub new_from_cache {
my $self = shift;
my %args = @_;
my $has_libs;
unless ($has_libs = defined &nfreeze) {
$has_libs = eval <<END;
use Storable 'lock_store','lock_retrieve';
use File::Path 'mkpath';
1;
END
warn "You need Storable to use new_from_cache(); returning uncached data" unless $has_libs;
}
$Storable::Deparse = 1;
$Storable::Eval = 1;
my $file = $has_libs && $args{-file} or return $self->_new(@_);
(my $name = $args{-file}) =~ s!/!_!g;
my $cachefile = $self->cachefile($name);
if (-e $cachefile && (stat(_))[9] >= $self->file_mtime($args{-file})) { # cache is valid
# if (-e $cachefile && -M $cachefile < 0) { # cache is valid
my $parsed_file = lock_retrieve($cachefile);
$parsed_file->initialize_code if $parsed_file->safe;
return $parsed_file;
} else {
mkpath(dirname($cachefile));
my $parsed = $self->_new(@_);
$parsed->initialize_code();
eval {lock_store($parsed,$cachefile)};
warn $@ if $@;
return $parsed;
}
}
sub cachedir {
my $self = shift;
my $uid = $<;
return File::Spec->catfile(File::Spec->tmpdir,"bio_graphics_ff_cache_${uid}");
}
sub cachefile {
my $self = shift;
my $name = shift;
return File::Spec->catfile($self->cachedir,$name);
}
=item $mtime = Bio::Graphics::FeatureFile->file_mtime($path)
Return the modification time of the indicated feature file without performing a full parse. This
takes into account the various #include and #exec directives and returns the maximum mtime of
any of the included files. Any #exec directive will return the current time. This is
useful for caching the parsed data structure.
=back
=cut
sub file_mtime {
my $self = shift;
my $file = shift;
my $mtime = 0;
for my $f (glob($file)) {
my $m = (stat($f))[9] or next;
$mtime = $m if $mtime < $m;
open my $fh,'<',$file or next;
my $cwd = getcwd();
chdir(dirname($file));
local $_;
while (<$fh>) {
if (/^\#exec/) {
return time(); # now!
}
if (/^\#include\s+(.+)/i) { # #include directive
my ($include_file) = shellwords($1);
my $m = $self->file_mtime($include_file);
$mtime = $m if $mtime < $m;
}
}
chdir($cwd);
}
return $mtime;
}
sub file_list {
my $self = shift;
my @list = ();
my $file = shift;
for my $f (glob($file)) {
open my $fh,'<',$file or next;
my $cwd = getcwd();
chdir(dirname($file));
while (<$fh>) {
if (/^\#include\s+(.+)/i) { # #include directive
my ($include_file) = shellwords($1);
my @files = glob($include_file);
@files ? @list = (@list,@files) : push(@list,$include_file);
}
}
chdir($cwd);
}
return \@list;
}
# render our features onto a panel using configuration data
# return the number of tracks inserted
=over 4
=item ($rendered,$panel,$tracks) = $features-E<gt>render([$panel, $position_to_insert, $options, $max_bump, $max_label, $selector])
Render features in the data set onto the indicated
Bio::Graphics::Panel. If no panel is specified, creates one.
All arguments are optional.
$panel is a Bio::Graphics::Panel that has previously been created and
configured.
lib/Bio/Graphics/FeatureFile.pm view on Meta::CPAN
} elsif ($options == 3) { #expand and label
push @pack_options,(-bump=>1,-label=>1);
} elsif ($options == 4) { #hyperexpand
push @pack_options,(-bump => 2);
} elsif ($options == 5) { #hyperexpand and label
push @pack_options,(-bump => 2,-label=>1);
}
}
for my $label (@labels_to_render) {
my @types = shellwords($self->setting($label=>'feature')||'');
@types = $label unless @types;
next if defined $selector and !$selector->($self,$label);
my @features = !$range ? grep {$self->_visible($_)} $self->features(\@types)
: $self->features(-types => \@types,
-seq_id => $range->seq_id,
-start => $range->start,
-end => $range->end
);
next unless @features; # suppress tracks for features that don't appear
# fix up funky group hack
foreach (@features) {$_->primary_tag('group') if $_->has_tag('_ff_group')};
my $features = \@features;
my @auto_bump;
push @auto_bump,(-bump => @$features < $max_bump) if defined $max_bump;
push @auto_bump,(-label => @$features < $max_label) if defined $max_label;
my @more_arguments = $override_options ? @$override_options : ();
my @config = ( -glyph => 'segments', # really generic
-bgcolor => $COLORS[$color++ % @COLORS],
-label => 1,
-description => 1,
-key => $features[0]->type || $label,
@auto_bump,
@base_config, # global
$self->style($label), # feature-specific
@pack_options,
@more_arguments,
);
if (defined($position_to_insert)) {
push @tracks,$panel->insert_track($position_to_insert++,$features,@config);
} else {
push @tracks,$panel->add_track($features,@config);
}
}
return wantarray ? (scalar(@tracks),$panel,\@tracks) : scalar @tracks;
}
sub _stat {
my $self = shift;
my $file = shift;
defined fileno($file) or return;
my @stat = stat($file) or return;
if ($self->{stat} && @{$self->{stat}}) { # merge #includes so that mtime etc are max age
for (8,9,10) {
$self->{stat}[$_] = $stat[$_] if $stat[$_] > $self->{stat}[$_];
}
$self->{stat}[7] += $stat[7];
} else {
$self->{stat} = \@stat;
}
}
sub _visible {
my $self = shift;
my $feat = shift;
my $min = $self->min;
my $max = $self->max;
return $feat->start<=$max && $feat->end>=$min;
}
=over 4
=item $error = $features-E<gt>error([$error])
Get/set the current error message.
=back
=cut
sub error {
my $self = shift;
my $d = $self->{error};
$self->{error} = shift if @_;
$d;
}
=over 4
=item $smart_features = $features-E<gt>smart_features([$flag]
Get/set the "smart_features" flag. If this is set, then any features
added to the featurefile object will have their configurator() method
called using the featurefile object as the argument.
=back
=cut
sub smart_features {
my $self = shift;
my $d = $self->{smart_features};
$self->{smart_features} = shift if @_;
$d;
}
sub parse_argv {
my $self = shift;
local $/ = "\n";
local $_;
while (<>) {
chomp;
$self->parse_line($_);
}
}
sub parse_file {
my $self = shift;
my $file = shift;
$file =~ s/(\s)/\\$1/g; # escape whitespace from glob expansion
for my $f (glob($file)) {
my $fh = IO::File->new($f) or return;
my $cwd = getcwd();
chdir(dirname($f));
$self->parse_fh($fh);
chdir($cwd);
}
}
sub parse_fh {
my $self = shift;
my $fh = shift;
$self->_stat($fh);
local $/ = "\n";
local $_;
while (<$fh>) {
chomp;
$self->parse_line($_) || last;
}
}
sub parse_text {
my $self = shift;
my $text = shift;
foreach (split m/\015?\012|\015\012?/,$text) {
$self->parse_line($_);
}
}
sub parse_line {
my $self = shift;
my $line = shift;
$line =~ s/\015//g; # get rid of carriage returns left over by MS-DOS/Windows systems
$line =~ s/\s+$//; # get rid of trailing whitespace
if (/^#include\s+(.+)/i) { # #include directive
my ($include_file) = shellwords($1);
# detect some loops
croak "#include loop detected at $include_file"
if $self->{includes}{$include_file}++;
$self->parse_file($include_file);
return 1;
}
if (/^#exec\s+(.+)/i) { # #exec directive
my ($command,@args) = shellwords($1);
open (my $fh,'-|') || exec $command,@args;
$self->parse_fh($fh);
return 1;
}
return 1 if $line =~ /^\s*\#[^\#]?$/; # comment line
# Are we in a configuration section or a data section?
# We start out in 'config' state, and are triggered to
# reenter config state whenever we see a /^\[ pattern (config section)
my $old_state = $self->{state};
my $new_state = $self->_state_transition($line);
if ($new_state ne $old_state) {
delete $self->{current_config};
delete $self->{current_tag};
}
if ($new_state eq 'config') {
$self->parse_config_line($line);
} elsif ($new_state eq 'data') {
$self->parse_data_line($line);
}
$self->{state} = $new_state;
1;
lib/Bio/Graphics/FeatureFile.pm view on Meta::CPAN
}
sub base2package {
my $self = shift;
return $self->{base2package} if exists $self->{base2package};
my $rand = int rand(1000000);
return $self->{base2package} = "Bio::Graphics::FeatureFile::CallBack::P$rand";
}
sub split_group {
my $self = shift;
my $gff = $self->{gff} ||= Bio::DB::GFF->new(-adaptor=>'memory');
return $gff->split_group(shift, $self->{gff_version} > 2);
}
# create a panel if needed
sub new_panel {
my $self = shift;
my $options = shift;
eval "require Bio::Graphics::Panel" unless Bio::Graphics::Panel->can('new');
# general configuration of the image here
my $width = $self->setting(general => 'pixels')
|| $self->setting(general => 'width')
|| WIDTH;
my ($start,$stop);
my $range_expr = '(-?\d+)(?:-|\.\.)(-?\d+)';
if (my $bases = $self->setting(general => 'bases')) {
($start,$stop) = $bases =~ /([\d-]+)(?:-|\.\.)([\d-]+)/;
}
if (!defined $start || !defined $stop) {
$start = $self->min unless defined $start;
$stop = $self->max unless defined $stop;
}
my $new_segment = Bio::Graphics::Feature->new(-start=>$start,-stop=>$stop);
my @panel_options = %$options if $options && ref $options eq 'HASH';
my $panel = Bio::Graphics::Panel->new(-segment => $new_segment,
-width => $width,
-key_style => 'between',
$self->style('general'),
@panel_options
);
$panel;
}
=over 4
=item $mtime = $features-E<gt>mtime
=item $atime = $features-E<gt>atime
=item $ctime = $features-E<gt>ctime
=item $size = $features-E<gt>size
Returns stat() information about the data file, for featurefile
objects created using the -file option. Size is in bytes. mtime,
atime, and ctime are in seconds since the epoch.
=back
=cut
sub mtime {
my $self = shift;
my $d = $self->{m_time} || $self->{stat}->[9];
$self->{m_time} = shift if @_;
$d;
}
sub atime { shift->{stat}->[8]; }
sub ctime { shift->{stat}->[10]; }
sub size { shift->{stat}->[7]; }
=over 4
=item $label = $features-E<gt>feature2label($feature)
Given a feature, determines the configuration stanza that bests
describes it. Uses the feature's type() method if it has it (DasI
interface) or its primary_tag() method otherwise.
=back
=cut
sub feature2label {
my $self = shift;
my $feature = shift;
my $type = $feature->can('type') ? $feature->type
: $feature->primary_tag;
$type or return;
(my $basetype = $type) =~ s/:.+$//;
my @labels = $self->type2label($type);
@labels = $self->type2label($basetype) unless @labels;
@labels = ($type) unless @labels;
wantarray ? @labels : $labels[0];
}
=over 4
=item $link = $features-E<gt>link_pattern($linkrule,$feature,$panel)
Given a feature, tries to generate a URL to link out from it. This
uses the 'link' option, if one is present. This method is a
convenience for the generic genome browser.
=back
=cut
sub link_pattern {
my $self = shift;
my ($linkrule,$feature,$panel,$dont_escape) = @_;
$panel ||= 'Bio::Graphics::Panel';
( run in 1.648 second using v1.01-cache-2.11-cpan-39bf76dae61 )