118
118
use Bio::Graphics::Feature;
119
119
use Bio::DB::GFF::Util::Rearrange;
120
use Carp 'cluck','carp','croak';
121
# use Bio::DB::GFF; # not needed - load later
123
use Text::Shellwords;
123
use Text::ParseWords 'shellwords';
125
125
# default colors for unconfigured features
126
126
my @COLORS = qw(cyan blue red yellow green wheat turquoise orange);
127
128
use constant WIDTH => 600;
129
use constant MAX_REMAP => 100;
233
=item ($rendered,$panel) = $features-E<gt>render([$panel])
236
=item ($rendered,$panel) = $features-E<gt>render([$panel, $position_to_insert, $options, $max_bump, $max_label, $selector])
235
238
Render features in the data set onto the indicated
236
239
Bio::Graphics::Panel. If no panel is specified, creates one.
241
All arguments are optional.
243
$panel is a Bio::Graphics::Panel that has previously been created and
246
$position_to_insert indicates the position at which to start inserting
247
new tracks. The last current track on the panel is assumed.
249
$options is a scalar used to control automatic expansion of the
250
tracks. 0=auto, 1=compact, 2=expanded, 3=expand and label,
251
4=hyperexpand, 5=hyperexpand and label.
253
$max_bump and $max_label indicate the maximum number of features
254
before bumping and labeling are turned off.
256
$selector is a code ref that can be used to filter which features to
257
render. It receives a feature and should return true to include the
258
feature and false to exclude it.
238
260
In a scalar context returns the number of tracks rendered. In a list
239
context, returns a two-element list containing the number of features
240
rendered and the panel. Use this form if you want the panel created
261
context, returns a three-element list containing the number of
262
features rendered, the created panel, and a list of all the track
284
306
for my $type (@configured_types,@unconfigured_types) {
285
my $features = $self->features($type);
307
next if defined $selector && !$selector->($self,$type);
308
next unless length $type > 0; # avoid empty ''
309
my $f = $self->features($type);
310
my @features = grep {$self->{visible}{$_} || $_->type eq 'group'} @$f;
311
next unless @features; # suppress tracks for features that don't appear
312
my $features = \@features;
287
315
push @auto_bump,(-bump => @$features < $max_bump) if defined $max_bump;
288
316
push @auto_bump,(-label => @$features < $max_label) if defined $max_label;
299
328
if (defined($position_to_insert)) {
300
$panel->insert_track($position_to_insert++,$features,@config);
329
push @tracks,$panel->insert_track($position_to_insert++,$features,@config);
302
$panel->add_track($features,@config);
331
push @tracks,$panel->add_track($features,@config);
306
return wantarray ? ($tracks,$panel) : $tracks;
334
return wantarray ? (scalar(@tracks),$panel,\@tracks) : scalar @tracks;
458
495
my($ref,$type,$name,$strand,$bounds,$description,$url,$score,%attributes);
460
if (@tokens >= 8) { # conventional GFF file
499
# conventional GFF file, with check for numeric start/end
500
if (@tokens >= 8 && $tokens[3]=~ /^-?\d+$/ && $tokens[4]=~ /^-?\d+$/) {
501
require Bio::DB::GFF unless Bio::DB::GFF->can('split_group');
461
502
my ($r,$source,$method,$start,$stop,$scor,$s,$phase,@rest) = @tokens;
462
504
my $group = join ' ',@rest;
463
505
$type = defined $source && $source ne '.' ? join(':',$method,$source) : $method;
464
$bounds = join '..',$start,$stop;
506
#$bounds = join '..',$start,$stop;
507
@parts = ([$start,$stop]);
467
510
my ($notes,@notes);
501
544
$self->{refs}{$ref}++ if defined $ref;
503
my @parts = map { [/(-?\d+)(?:-|\.\.)(-?\d+)/]} split /(?:,| )\s*/,$bounds;
546
@parts = map { [/(-?\d+)(?:-|\.\.)(-?\d+)/]} split /(?:,| )\s*/,$bounds
547
if $bounds && !@parts;
505
549
foreach (@parts) { # max and min calculation, sigh...
506
$self->{min} = $_->[0] if !defined $self->{min} || $_->[0] < $self->{min};
507
$self->{max} = $_->[1] if !defined $self->{max} || $_->[1] > $self->{max};
550
$self->{min} = $_->[0] if defined $_->[0] && defined $self->{min} ? ($_->[0] < $self->{min}) : 1;
551
$self->{max} = $_->[1] if defined $_->[1] && defined $self->{max} ? ($_->[1] > $self->{max}) : 1;
510
556
if ($self->{coordinate_mapper} && $ref) {
511
($ref,@parts) = $self->{coordinate_mapper}->($ref,@parts);
512
return 1 unless $ref;
557
my @remapped = $self->{coordinate_mapper}->($ref,@parts);
558
($ref,@parts) = @remapped if @remapped;
559
$visible = @remapped;
560
return 1 if !$visible && $self->{feature_count} > MAX_REMAP;
515
563
$type = '' unless defined $type;
516
564
$name = '' unless defined $name;
566
# if strand is not explicitly given in file, we infer it
567
# from the order of start and end coordinates
568
# (this is to deal with confusing documentation, actually)
569
unless (defined $strand) {
571
if (defined $_ && ref($_) eq 'ARRAY' && defined $_->[0] && defined $_->[1]) {
572
$strand ||= $_->[0] <= $_->[1] ? '+' : '-';
573
($_->[0],$_->[1]) = ($_->[1],$_->[0]) if $_->[0] > $_->[1];
518
578
# attribute handling
519
if (defined $description && $description =~ /\w+=\w+/) { # attribute line
579
if (defined $description && $description =~ /\w+=\S+/) { # attribute line
520
580
my @attributes = split /;\s*/,$description;
521
581
foreach (@attributes) {
522
582
my ($name,$value) = split /=/,$_,2;
715
790
# return configuration information
716
791
# arguments are ($type) => returns tags for type
717
792
# ($type=>$tag) => returns values of tag on type
793
# ($type=>$tag,$value) => sets value of tag
719
795
my $self = shift;
720
796
my $config = $self->{config} or return;
721
797
return keys %{$config} unless @_;
722
return keys %{$config->{$_[0]}} if @_ == 1;
723
return $config->{$_[0]}{$_[1]} if @_ > 1;
798
return keys %{$config->{$_[0]}} if @_ == 1;
799
return $config->{$_[0]}{$_[1]} if @_ == 2 && exists $config->{$_[0]};
800
return $config->{$_[0]}{$_[1]} = $_[2] if @_ > 2;
750
828
my $package = $self->base2package;
751
829
my $codestring = "\\&${package}\:\:${subroutine_name}";
752
830
my $coderef = eval $codestring;
831
$self->_callback_complain($section,$option) if $@;
754
832
$self->set($section,$option,$coderef);
757
elsif ($setting =~ /^sub\s*\{/) {
758
my $coderef = eval $setting;
835
elsif ($setting =~ /^sub\s*(\(\$\$\))*\s*\{/) {
836
my $package = $self->base2package;
837
my $coderef = eval "package $package; $setting";
838
$self->_callback_complain($section,$option) if $@;
760
839
$self->set($section,$option,$coderef);
912
997
# return features
914
999
my $self = shift;
915
my ($types,$iterator,@rest) = defined($_[0] && $_[0]=~/^-/) ? rearrange([['TYPE','TYPES']],@_) : (\@_);
1000
my ($types,$iterator,@rest) = defined($_[0] && $_[0]=~/^-/)
1001
? rearrange([['TYPE','TYPES']],@_) : (\@_);
916
1002
$types = [$types] if $types && !ref($types);
917
1003
my @types = ($types && @$types) ? @$types : $self->types;
918
1004
my @features = map {@{$self->{features}{$_}}} @types;
970
1056
$self->features(@args);
1059
=head2 get_feature_by_name
1061
Usage : $db->get_feature_by_name(-name => $name)
1062
Function: fetch features by their name
1063
Returns : a list of Bio::DB::GFF::Feature objects
1064
Args : the name of the desired feature
1067
This method can be used to fetch a named feature from the file.
1069
The full syntax is as follows. Features can be filtered by
1070
their reference, start and end positions
1072
@f = $db->get_feature_by_name(-name => $name,
1073
-ref => $sequence_name,
1077
This method may return zero, one, or several Bio::Graphics::Feature
1082
sub get_feature_by_name {
1084
my ($name,$ref,$start,$end) = rearrange(['NAME','REF','START','END'],@_);
1085
my $match = <<'END';
1089
if (defined $name) {
1090
if ($name =~ /[\?\*]/) { # regexp
1091
$name = quotemeta($name);
1092
$name =~ s/\\\?/.?/g;
1093
$name =~ s/\\\*/.*/g;
1094
$match .= " return unless \$f->display_name =~ /$name/i;\n";
1096
$match .= " return unless \$f->display_name eq '$name';\n";
1101
$match .= " return unless \$f->ref eq '$ref';\n";
1103
if (defined $start && $start =~ /^-?\d+$/) {
1104
$match .= " return unless \$f->stop >= $start;\n";
1106
if (defined $end && $end =~ /^-?\d+$/) {
1107
$match .= " return unless \$f->start <= $end;\n";
1109
$match .= " return 1;\n}";
1111
my $match_sub = eval $match;
1112
unless ($match_sub) {
1117
return grep {$match_sub->($_)} $self->features;
1122
Title : search_notes
1123
Usage : @search_results = $db->search_notes("full text search string",$limit)
1124
Function: Search the notes for a text string
1125
Returns : array of results
1126
Args : full text search string, and an optional row limit
1129
Each row of the returned array is a arrayref containing the following fields:
1131
column 1 Display name of the feature
1132
column 2 The text of the note
1133
column 3 A relevance score.
1139
my ($search_string,$limit) = @_;
1141
$search_string =~ tr/*?//d;
1144
my $search = join '|',map {quotemeta($_)} $search_string =~ /(\S+)/g;
1146
for my $feature ($self->features) {
1147
next unless $feature->{attributes};
1148
my @attributes = $feature->all_tags;
1149
my @values = map {$feature->each_tag_value} @attributes;
1150
push @values,$feature->notes if $feature->notes;
1151
push @values,$feature->display_name if $feature->display_name;
1152
next unless @values;
1153
my $value = "@values";
1156
my @hits = $value =~ /($search)/ig;
1157
$note ||= $value if @hits;
1159
next unless $matches;
1161
my $relevance = 10 * $matches;
1162
push @results,[$feature,$note,$relevance];
1163
last if @results >= $limit;
973
1170
=head2 get_feature_stream(), top_SeqFeatures(), all_SeqFeatures()
975
1172
Provided for compatibility with older BioPerl and/or Bio::DB::GFF
1167
1367
my $self = shift;
1168
my $feature = shift;
1169
for my $label ($self->feature2label($feature)) {
1170
my $link = $self->setting($label,'link');
1171
$link = $self->setting(general=>'link') unless defined $link;
1173
return $self->link_pattern($link,$feature);
1368
my ($linkrule,$feature,$panel) = @_;
1370
$panel ||= 'Bio::Graphics::Panel';
1372
if (ref($linkrule) && ref($linkrule) eq 'CODE') {
1373
my $val = eval {$linkrule->($feature,$panel)};
1374
$self->_callback_complain(none=>"linkrule for $feature") if $@;
1180
my ($pattern,$feature,$panel) = @_;
1181
1378
require CGI unless defined &CGI::escape;
1183
$pattern =~ s/\$(\w+)/
1380
$linkrule ||= ''; # prevent uninit warning
1381
$linkrule =~ s/\$(\w+)/
1185
$1 eq 'ref' ? ($n = $feature->location->seq_id) && "$n"
1186
: $1 eq 'name' ? ($n = $feature->display_name) && "$n" # workaround broken CGI.pm
1383
$1 eq 'ref' ? (($n = $feature->location->seq_id) && "$n") || ''
1384
: $1 eq 'name' ? (($n = $feature->display_name) && "$n") || ''
1187
1385
: $1 eq 'class' ? eval {$feature->class} || ''
1188
: $1 eq 'type' ? eval {$feature->method} || $feature->primary_tag
1189
: $1 eq 'method' ? eval {$feature->method} || $feature->primary_tag
1190
: $1 eq 'source' ? eval {$feature->source} || $feature->source_tag
1191
: $1 eq 'start' ? $feature->start
1192
: $1 eq 'end' ? $feature->end
1193
: $1 eq 'stop' ? $feature->end
1194
: $1 eq 'segstart' ? $panel->start
1195
: $1 eq 'segend' ? $panel->end
1386
: $1 eq 'type' ? eval {$feature->method} || $feature->primary_tag || ''
1387
: $1 eq 'method' ? eval {$feature->method} || $feature->primary_tag || ''
1388
: $1 eq 'source' ? eval {$feature->source} || $feature->source_tag || ''
1389
: $1 eq 'start' ? $feature->start || ''
1390
: $1 eq 'end' ? $feature->end || ''
1391
: $1 eq 'stop' ? $feature->end || ''
1392
: $1 eq 'segstart' ? $panel->start || ''
1393
: $1 eq 'segend' ? $panel->end || ''
1196
1394
: $1 eq 'description' ? eval {join '',$feature->notes} || ''
1197
: $1 eq 'id' ? $feature->feature_id
1395
: $1 eq 'id' ? $feature->feature_id || ''
1404
my ($feature,$panel) = @_;
1406
for my $label ($self->feature2label($feature)) {
1407
my $linkrule = $self->setting($label,'link');
1408
$linkrule = $self->setting(general=>'link') unless defined $linkrule;
1409
return $self->link_pattern($linkrule,$feature,$panel);
1415
my $feature = shift;
1417
for my $label ($self->feature2label($feature)) {
1418
my $linkrule = $self->setting($label,'title');
1419
$linkrule ||= $self->setting(general=>'title');
1420
next unless $linkrule;
1421
return $self->link_pattern($linkrule,$feature);
1424
my $method = eval {$feature->method} || $feature->primary_tag;
1425
my $seqid = $feature->can('seq_id') ? $feature->seq_id : $feature->location->seq_id;
1427
if ($feature->can('target') && (my $target = $feature->target)) {
1430
(defined $seqid ? "$seqid:" : '').
1431
$feature->start."..".$feature->end,
1432
$feature->target.':'.
1433
$feature->target->start."..".$feature->target->end);
1437
$feature->can('display_name') ? $feature->display_name : $feature->info,
1438
(defined $seqid ? "$seqid:" : '').
1439
($feature->start||'?')."..".($feature->end||'?')
1204
1447
# given a feature type, return its label(s)
added
removed
Bio/Graphics/FeatureFile.pm
