AcePerl
view release on metacpan or search on metacpan
$self->file_cache_store($obj);
}
push @result,$obj;
}
return @result;
}
# return a portion of the active list
sub _fetch {
my $self = shift;
my ($count,$start,$tag) = @_;
my (@result);
$tag = '' unless defined $tag;
my $query = "show -j $tag";
$query .= ' -T' if $self->{timestamps};
$query .= " -b $start" if defined $start;
$query .= " -c $count" if defined $count;
$self->{database}->query($query);
while (my @objects = $self->_fetch_chunk) {
push (@result,@objects);
}
# copy tag into a portion of the tree
if ($tag) {
for my $tree (@result) {
my $obj = $self->class_for($tree->class,$tree->name)->new($tree->class,$tree->name,$self,1);
$obj->_attach_subtree($tag=>$tree);
This will fetch all Sequences named D123* and fill in their Visible
trees in a single operation.
Other arguments in the named parameter calling form are B<-count>, to
retrieve a certain maximum number of objects, and B<-offset>, to
retrieve objects beginning at the indicated offset into the list. If
you want to limit the number of objects returned, but wish to learn
how many objects might have been retrieved, pass a reference to a
scalar variable in the B<-total> argument. This will return the
object count. This example shows how to fetch 100 Sequence
objects, starting at Sequence number 500:
@some_sequences = $db->fetch('Sequence','*',100,500);
The next example uses the named argument form to fetch 100 Sequence
objects starting at Sequence number 500, and leave the total number of
Sequences in $total:
@some_sequences = $db->fetch(-class => 'Sequence',
-count => 100,
-offset => 500,
-total => \$total);
Notice that if you leave out the B<-name> argument the "*" wildcard is
assumed.
Ace/Browser/AceSubs.pm view on Meta::CPAN
@COOKIES = ();
# keeps track of what sections should be open
%OPEN = param('open') ? map {$_ => 1} split(' ',param('open')) : () ;
return 1 if Configuration();
# if we get here, it is a big NOT FOUND error
print header(-status=>'404 Not Found',-type=>'text/html');
$HEADER++;
print start_html(-title => 'Database Not Found',
-style => Ace::Browser::SiteDefs->getConfig(DEFAULT_DATABASE)->Style,
),
h1('Database not found'),
p('The requested database',i(get_symbolic()),'is not recognized',
'by this server.');
print p('Please return to the',a({-href=>referer()},'referring page.')) if referer();
print end_html;
Apache::exit(0) if defined &Apache::exit; # bug out of here!
exit(0);
}
Ace/Browser/AceSubs.pm view on Meta::CPAN
This subroutine is not exported by default.
=cut
sub AceMultipleChoices {
my ($symbol,$report,$objects) = @_;
if ($objects && @$objects == 1) {
my $destination = Object2URL($objects->[0]);
AceHeader(-Refresh => "1; URL=$destination");
print start_html (
'-Title' => 'Redirect',
'-Style' => Style(),
),
h1('Redirect'),
p("Automatically transforming this query into a request for corresponding object",
ObjectLink($objects->[0],$objects->[0]->class.':'.$objects->[0])),
p("Please wait..."),
Footer(),
end_html();
return;
Ace/Browser/AceSubs.pm view on Meta::CPAN
############### redirect to a different report #####################
sub AceRedirect {
my ($report,$object) = @_;
my $url = Configuration()->display($report,'url');
my $args = ref($object) ? "name=$object&class=".$object->class
: "name=$object";
my $destination = ResolveUrl($url => $args);
AceHeader(-Refresh => "1; URL=$destination");
print start_html (
'-Title' => 'Redirect',
'-Style' => Style(),
'-head' => meta({-http_equiv=>'Refresh',-content=>"1; URL=$destination"})
),
h1('Redirect'),
p("This request is being redirected to the \U$report\E display"),
p("This page will automatically display the requested object in",
"one seconds",a({-href=>$destination},'Click on this link'),
'to load the page immediately.'),
end_html();
Ace/Browser/AceSubs.pm view on Meta::CPAN
$class If no AceDB object is available, then you can pass
a string containing the AceDB class that this page is
designed to display.
$title A title to use for the HTML page and the first level-one
header. If not provided, a generic title "Report for
Object" is generated.
@html_headers Additional HTML headers to pass to the the CGI.pm
start_html.
=cut
# boilerplate for the top of the page
sub PrintTop {
my ($object,$class,$title,@additional_header_stuff) = @_;
return if $TOP++;
$class = $object->class if defined $object && ref($object);
$class ||= param('class') unless defined($title);
AceHeader();
$title ||= defined($object) ? "$class Report for: $object" : $class ? "$class Report" : ''
unless defined($title);
print start_html (
'-Title' => $title,
'-Style' => Style(),
@additional_header_stuff,
);
print Header();
print TypeSelector($object,$class) if defined $object;
print h1($title) if $title;
}
=item PrintBottom()
Ace/Browser/AceSubs.pm view on Meta::CPAN
=item $hashref = Style()
This subroutine returns a hashref containing a reference to the
configured stylesheet, in the following format:
{ -src => '/ace/stylesheets/current_stylesheet.css' }
This hash is suitable for passing to the -style argument of CGI.pm's
start_html() function, or for use as an additional header in
PrintTop(). You may add locally-defined stylesheet elements to the
hash before calling start_html(). See the pic script for an example
of how this is done this.
This function is not exported by default.
=cut
=item $url = ResolveUrl($url,$param)
Given a URL and a set of parameters, this function does the necessary
magic to add the symbolic database name to the end of the URL (if
Ace/Browser/SearchSubs.pm view on Meta::CPAN
Ace::Browser::SearchSubs - Subroutines for AceBrowser search scripts
=head1 SYNOPSIS
use Ace;
use Ace::Browser::AceSubs;
use Ace::Browser::SearchSubs;
use CGI qw(:standard);
my $form = p(start_form,
textfield(-name=>'query'),
end_form);
AceSearchTable('Search for stuff',$form);
...
my $query = param('query');
my $offset = AceSearchOffset;
my ($objects,$count) = do_search($query,$offset);
AceResultsTable($objects,$count,$offset,'Here are results');
Ace/Browser/SearchSubs.pm view on Meta::CPAN
Given a title and the HTML contents, this formats the search into a
table and gives it the background and foreground colors used elsewhere
for searches. The formatted search is then printed.
The HTML contents are usually a fill-out form. For convenience, you
can provide the contents in multiple parts (lines or elements) and
they will be concatenated together.
If the first argument is a hashref, then its contents will be passed
to start_form() to override the form arguments.
=cut
sub AceSearchTable {
my %attributes = %{shift()} if ref($_[0]) eq 'HASH';
my ($title,@body) = @_;
print
start_form(-action=>url(-absolute=>1,-path_info=>1).'#results',%attributes),
a({-name=>'search'},''),
table({-border=>0,-width=>'100%'},
TR({-valign=>'MIDDLE'},
td({-class=>'searchbody'},@body))),
end_form;
}
=item AceResultsTable($objects,$count,$offset,$title)
This subroutine formats the results of a search into a pageable list
Ace/Browser/SearchSubs.pm view on Meta::CPAN
my ($objects,$count,$offset,$title) = @_;
Delete('scroll');
param(-name=>'offset',-value=>$offset);
my @cheaders = map { $offset + ROWS * $_ } (0..(@$objects-1)/ROWS) if @$objects;
my @rheaders = (1..min(ROWS,$count));
$title ||= 'Search Results';
print
a({-name=>'results'},''),
start_table({-border=>0,-cellspacing=>2,-cellpadding=>2,-width=>'100%',-align=>'CENTER',-class=>'resultsbody'}),
TR(th({-class=>'resultstitle'},$title));
unless (@$objects) {
print end_table,p();
return;
}
print start_Tr,start_td;
my $need_navbar = $offset > 0 || $count >= MAXOBJECTS;
my @buttons = make_navigation_bar($offset,$count) if $need_navbar;
print table({-width=>'50%',-align=>'CENTER'},Tr(@buttons)) if $need_navbar;
print table({-width=>'100%'},tableize(ROWS,COLS,\@rheaders,\@cheaders,@$objects));
print end_td,end_Tr,end_table,p();
}
Ace/Browser/SearchSubs.pm view on Meta::CPAN
}
my @hidden;
Delete('scroll');
Delete('Go');
foreach (param()) {
push(@hidden,hidden(-name=>$_,-value=>[param($_)]));
}
push(@buttons,
td({-valign=>'MIDDLE',-align=>'CENTER'},
start_form({-name=>'form1'}),
submit(-name=>'Go',-label=>'Go to'),
'page',
popup_menu(-name=>'scroll',-Values=>\@v,-labels=>\%v,
-default=>($page-1)*MAXOBJECTS-$offset,
-override=>1,
-onChange=>'document.form1.submit()'),
"of $pages",
@hidden,
end_form()
)
Ace/Graphics/Fk.pm view on Meta::CPAN
package Ace::Graphics::Fk;
use strict;
*stop = \&end;
*primary_tag = \&name;
*exons = \&segments;
# usage:
# Ace::Graphics::Fk->new(
# -start => 1,
# -end => 100,
# -name => 'fred feature',
# -info => $additional_stuff_to_store,
# -strand => +1);
#
# Alternatively, use -segments => [ [start,stop],[start,stop]...]
# to create a multisegmented feature.
sub new {
my $class= shift;
my %arg = @_;
my $self = bless {},$class;
$arg{-strand} ||= 0;
$self->{strand} = $arg{-strand} >= 0 ? +1 : -1;
$self->{name} = $arg{-name};
$self->{info} = $arg{-info};
if (my $s = $arg{-segments}) {
my @segments;
for my $seg (@$s) {
if (ref($seg) eq 'ARRAY') {
push @segments,$class->new(-start=>$seg->[0],
-stop=>$seg->[1],
-strand=>$self->{strand});
} else {
push @segments,$seg;
}
}
$self->{segments} = [ sort {$a->start <=> $b->start } @segments ];
} else {
$self->{start} = $arg{-start};
$self->{end} = $arg{-end} || $arg{-stop};
}
$self;
}
sub segments {
my $self = shift;
my $s = $self->{segments} or return;
@$s;
}
sub strand { shift->{strand} }
sub name { shift->{name} }
sub start {
my $self = shift;
if (my @segments = $self->segments) {
return $segments[0]->start;
}
return $self->{start};
}
sub end {
my $self = shift;
if (my @segments = $self->segments) {
return $segments[-1]->end;
}
return $self->{end};
}
sub length {
my $self = shift;
return $self->end - $self->start + 1;
}
sub introns {
my $self = shift;
return;
}
sub source_tag { 'dummy' }
sub target { }
sub info {
my $self = shift;
return $self->{info} || $self->name;
Ace/Graphics/Glyph.pm view on Meta::CPAN
use strict;
use GD;
# simple glyph class
# args: -feature => $feature_object
# args: -factory => $factory_object
sub new {
my $class = shift;
my %arg = @_;
my $feature = $arg{-feature};
my ($start,$end) = ($feature->start,$feature->end);
($start,$end) = ($end,$start) if $start > $end;
return bless {
@_,
top => 0,
left => 0,
right => 0,
start => $start,
end => $end
},$class;
}
# delegates
# any of these can be overridden safely
sub factory { shift->{-factory} }
sub feature { shift->{-feature} }
sub fgcolor { shift->factory->fgcolor }
sub bgcolor { shift->factory->bgcolor }
Ace/Graphics/Glyph.pm view on Meta::CPAN
sub width { shift->factory->width }
sub font { shift->factory->font }
sub option { shift->factory->option(shift) }
sub color {
my $self = shift;
my $factory = $self->factory;
my $color = $factory->option(shift) or return $self->fgcolor;
$factory->translate($color);
}
sub start { shift->{start} }
sub end { shift->{end} }
sub offset { shift->factory->offset }
sub length { shift->factory->length }
# this is a very important routine that dictates the
# height of the bounding box. We start with the height
# dictated by the factory, and then adjust if needed
sub height {
my $self = shift;
$self->{cache_height} = $self->calculate_height unless exists $self->{cache_height};
return $self->{cache_height};
}
sub calculate_height {
my $self = shift;
my $val = $self->factory->height;
Ace/Graphics/Glyph.pm view on Meta::CPAN
return $self->{left} + $self->{cache_left};
}
sub right {
my $self = shift;
$self->{cache_right} = $self->calculate_right unless exists $self->{cache_right};
return $self->{left} + $self->{cache_right};
}
sub calculate_left {
my $self = shift;
my $val = $self->{left} + $self->map_pt($self->{start} - 1);
$val > 0 ? $val : 0;
}
sub calculate_right {
my $self = shift;
my $val = $self->{left} + $self->map_pt($self->{end} - 1);
$val = 0 if $val < 0;
$val = $self->width if $val > $self->width;
if ($self->option('label') && (my $label = $self->label)) {
my $left = $self->left;
Ace/Graphics/Glyph.pm view on Meta::CPAN
sub box {
my $self = shift;
return ($self->left,$self->top,$self->right,$self->bottom);
}
# these are the sequence boundaries, exclusive of labels and doodads
sub calculate_boundaries {
my $self = shift;
my ($left,$top) = @_;
my $x1 = $left + $self->map_pt($self->{start} - 1);
$x1 = 0 if $x1 < 0;
my $x2 = $left + $self->map_pt($self->{end} - 1);
$x2 = 0 if $x2 < 0;
my $y1 = $top + $self->{top};
$y1 += $self->labelheight if $self->option('label');
my $y2 = $y1 + $self->factory->height;
$x2 = $x1 if $x2-$x1 < 1;
Ace/Graphics/Glyph.pm view on Meta::CPAN
Given a symbolic or #RRGGBB-form color name, returns its GD index.
=back
Retrieving information about the sequence:
=over 4
=item $start = $glyph->start
=item $end = $glyph->end
These methods return the start and end of the glyph in base pair
units.
=item $offset = $glyph->offset
Returns the offset of the segment (the base pair at the far left of
the image).
=item $length = $glyph->length
Returns the length of the sequence segment.
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
my $self = shift;
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my $fg = $self->fgcolor;
my $a2 = ($y2-$y1)/2;
my $center = $y1+$a2;
$gd->line($x1,$center,$x2,$center,$fg);
if ($self->feature->start < $self->offset) { # off left end
if ($x2 > $a2) {
$gd->line($x1,$center,$x1+$a2,$center-$a2,$fg); # arrowhead
$gd->line($x1,$center,$x1+$a2,$center+$a2,$fg);
}
} else {
$gd->line($x1,$center-$a2,$x1,$center+$a2,$fg); # tick/base
}
if ($self->feature->end > $self->offset + $self->length) {# off right end
if ($x1 < $x2-$a2-1) {
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
$self->draw_ticks($gd,@_) if $self->option('tick');
# add a label if requested
$self->draw_label($gd,@_) if $self->option('label');
}
sub draw_label {
my $self = shift;
my ($gd,$left,$top) = @_;
my $label = $self->label or return;
my $start = $self->left + ($self->right - $self->left - length($label) * $self->font->width)/2;
$gd->string($self->font,$left + $start,$top + $self->top,$label,$self->fontcolor);
}
sub draw_ticks {
my $self = shift;
my ($gd,$left,$top) = @_;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top);
my $a2 = ($y2-$y1)/2;
my $center = $y1+$a2;
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
my $fg = $self->fgcolor;
# figure out tick mark scale
# we want no more than 1 tick mark every 30 pixels
# and enough room for the labels
my $font = $self->font;
my $width = $font->width;
my $font_color = $self->fontcolor;
my $relative = $self->option('relative_coords');
my $start = $relative ? 1 : $self->feature->start;
my $stop = $start + $self->feature->length - 1;
my $reversed = 0;
if ($self->feature->strand == -1) {
$stop = -$stop;
$reversed = 1;
}
my $interval = 1;
my $mindist = 30;
my $widest = 5 + (length($stop) * $width);
$mindist = $widest if $widest > $mindist;
while (1) {
my $pixels = $interval * $scale;
last if $pixels >= $mindist;
$interval *= 10;
}
my $first_tick = $interval * int(0.5 + $start/$interval);
for (my $i = $first_tick; $i < $stop; $i += $interval) {
my $tickpos = !$reversed ? $left + $self->map_pt($i-1 + $self->feature->start)
: $left + $self->map_pt($self->feature->start - $i - 1);
$gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
my $middle = $tickpos - (length($i) * $width)/2;
$gd->string($font,$middle,$center+$a2-1,$i,$font_color)
if $middle > 0 && $middle < $self->factory->panel->width-($font->width * length $i);
}
if ($self->option('tick') >= 2) {
my $a4 = ($y2-$y1)/4;
for (my $i = $first_tick; $i < $stop; $i += $interval/10) {
my $tickpos = !$reversed ? $left + $self->map_pt($i-1 + $self->feature->start)
: $left + $self->map_pt($self->feature->start - $i - 1);
$gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
}
}
}
1;
__END__
Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN
$gtop = $self->factory->panel->pad_top;
$gbottom = $panel_height - $self->factory->panel->pad_bottom;
}
while (1) {
my $pixels = $interval * $scale;
last if $pixels >= $mindist;
$interval *= 10;
}
my $first_tick = $interval * int(0.5 + $self->start/$interval);
for (my $i = $first_tick; $i < $self->end; $i += $interval) {
my $tickpos = $left + $self->map_pt($i);
$gd->line($tickpos,$gtop,$tickpos,$gbottom,$gcolor) if defined $gcolor;
$gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
}
if ($self->option('tick') >= 2) {
my $a4 = $self->SUPER::height/4;
for (my $i = $first_tick - $interval; $i < $self->end; $i += $interval/10) {
Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN
-northeast Whether to draw the true
north or east arrowhead
(depending on orientation)
-southwest Whether to draw the true
south or west arrowhead
(depending on orientation)
Set -parallel to false to display a point-like feature such as a
polymorphism, or to indicate an important location. If the feature
start == end, then the glyph will draw a single arrow at the
designated location:
^
|
Otherwise, there will be two arrows at the start and end:
^ ^
| |
=head1 BUGS
Please report them.
=head1 SEE ALSO
Ace/Graphics/Glyph/graded_segments.pm view on Meta::CPAN
foreach (@segments) {
my $s = eval { $_->score };
$max_score = $s if $s > $max_score;
}
}
# allocate colors
my $fill = $self->fillcolor;
my %segcolors;
my ($red,$green,$blue) = $self->factory->rgb($fill);
foreach (sort {$a->start <=> $b->start} @segments) {
my $s = eval { $_->score };
unless (defined $s) {
$segcolors{$_} = $fill;
next;
}
my($r,$g,$b) = map {(255 - (255-$_) * ($s/$max_score))} ($red,$green,$blue);
my $idx = $self->factory->translate($r,$g,$b);
$segcolors{$_} = $idx;
}
# get parameters
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my ($left,$top) = @_;
my (@boxes,@skips);
for (my $i=0; $i < @segments; $i++) {
my $color = $segcolors{$segments[$i]};
my ($start,$stop) = ($left + $self->map_pt($segments[$i]->start),
$left + $self->map_pt($segments[$i]->end));
# probably unnecessary, but we do it out of paranaoia
($start,$stop) = ($stop,$start) if $start > $stop;
push @boxes,[$start,$stop,$color];
if (my $next_segment = $segments[$i+1]) {
my ($next_start,$next_stop) = ($left + $self->map_pt($next_segment->start),
$left + $self->map_pt($next_segment->end));
# probably unnecessary, but we do it out of paranaoia
($next_start,$next_stop) = ($next_stop,$next_start) if $next_start > $next_stop;
push @skips,[$stop+1,$next_start-1];
}
}
my $fg = $self->fgcolor;
my $center = ($y1 + $y2)/2;
# each skip becomes a simple line
for my $i (@skips) {
next unless $i->[1] - $i->[0] >= 1;
$gd->line($i->[0],$center,$i->[1],$center,$fg);
Ace/Graphics/Glyph/segments.pm view on Meta::CPAN
my $gd = shift;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
my ($left,$top) = @_;
my $gray = $self->color(GRAY);
my (@boxes,@skips);
my $stranded = $self->option('stranded');
for (my $i=0; $i < @segments; $i++) {
my ($start,$stop) = ($left + $self->map_pt($segments[$i]->start),
$left + $self->map_pt($segments[$i]->end));
my $strand = 0;
my $target;
if ($stranded
&& $segments[$i]->can('target')
&& ($target = $segments[$i]->target)
&& $target->can('start')) {
$strand = $target->start < $target->end ? 1 : -1;
}
# probably unnecessary, but we do it out of paranaoia
($start,$stop) = ($stop,$start) if $start > $stop;
push @boxes,[$start,$stop,$strand];
if (my $next_segment = $segments[$i+1]) {
my ($next_start,$next_stop) = ($left + $self->map_pt($next_segment->start),
$left + $self->map_pt($next_segment->end));
# probably unnecessary, but we do it out of paranaoia
($next_start,$next_stop) = ($next_stop,$next_start) if $next_start > $next_stop;
# fudge boxes that are within two pixels of each other
if ($next_start - $stop < 2) {
$boxes[-1][1] = $next_start;
}
push @skips,[$stop+1,$next_start-1];
}
}
my $fg = $self->fgcolor;
my $fill = $self->fillcolor;
my $center = ($y1 + $y2)/2;
# each segment becomes a box
for my $e (@boxes) {
my @rect = ($e->[0],$y1,$e->[1],$y2);
Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN
my ($left,$top) = @_;
my $implied_intron_color = $self->option('implied_intron_color') || IMPLIED_INTRON_COLOR;
my $gray = $self->factory->translate($implied_intron_color);
my $fg = $self->fgcolor;
my $fill = $self->fillcolor;
my $fontcolor = $self->fontcolor;
my $curated_exon = $self->option('curatedexon') ? $self->color('curatedexon') : $fill;
my $curated_intron = $self->option('curatedintron') ? $self->color('curatedintron') : $fg;
my @exons = sort {$a->start<=>$b->start} $self->feature->segments;
my @introns = $self->feature->introns if $self->feature->can('introns');
# fill in missing introns
my (%istart,@intron_boxes,@implied_introns,@exon_boxes);
foreach (@introns) {
my ($start,$stop) = ($_->start,$_->end);
($start,$stop) = ($stop,$start) if $start > $stop;
$istart{$start}++;
my $color = $_->source_tag eq 'curated' ? $curated_intron : $fg;
push @intron_boxes,[$left+$self->map_pt($start),$left+$self->map_pt($stop),$color];
}
for (my $i=0; $i < @exons; $i++) {
my ($start,$stop) = ($exons[$i]->start,$exons[$i]->end);
($start,$stop) = ($stop,$start) if $start > $stop;
my $color = $exons[$i]->source_tag eq 'curated' ? $curated_exon : $fill;
push @exon_boxes,[$left+$self->map_pt($start),my $stop_pos = $left + $self->map_pt($stop),$color];
next unless my $next_exon = $exons[$i+1];
my $next_start = $next_exon->start < $next_exon->end ?
$next_exon->start : $next_exon->end;
my $next_start_pos = $left + $self->map_pt($next_start);
# fudge boxes that are within two pixels of each other
if ($next_start_pos - $stop_pos < 2) {
$exon_boxes[-1][1] = $next_start_pos;
} elsif ($next_exon && !$istart{$stop+1}) {
push @implied_introns,[$stop_pos,$next_start_pos,$gray];
}
}
my $center = ($y1 + $y2)/2;
my $quarter = $y1 + ($y2-$y1)/4;
# each intron becomes an angly thing
for my $i (@intron_boxes,@implied_introns) {
if ($i->[1] - $i->[0] > 3) { # room for the inverted "V"
Ace/Graphics/Panel.pm view on Meta::CPAN
package Ace::Graphics::Panel;
# This embodies the logic for drawing multiple tracks.
use Ace::Graphics::Track;
use GD;
use Carp 'croak';
use strict;
use constant KEYLABELFONT => gdSmallFont;
use constant KEYSPACING => 10; # extra space between key columns
use constant KEYPADTOP => 5; # extra padding before the key starts
use constant KEYCOLOR => 'cornsilk';
*push_track = \&add_track;
# package global
my %COLORS;
# Create a new panel of a given width and height, and add lists of features
# one by one
sub new {
Ace/Graphics/Panel.pm view on Meta::CPAN
$class->read_colors() unless %COLORS;
my $length = $options{-length} || 0;
my $offset = $options{-offset} || 0;
my $spacing = $options{-spacing} || 5;
my $keycolor = $options{-keycolor} || KEYCOLOR;
my $keyspacing = $options{-keyspacing} || KEYSPACING;
$length ||= $options{-segment}->length if $options{-segment};
$offset ||= $options{-segment}->start-1 if $options{-segment};
return bless {
tracks => [],
width => $options{-width} || 600,
pad_top => $options{-pad_top}||0,
pad_bottom => $options{-pad_bottom}||0,
pad_left => $options{-pad_left}||0,
pad_right => $options{-pad_right}||0,
length => $length,
offset => $offset,
Ace/Graphics/Panel.pm view on Meta::CPAN
Ace::Graphics::Panel - PNG graphics of Ace::Sequence::Feature objects
=head1 SYNOPSIS
use Ace::Sequence;
use Ace::Graphics::Panel;
my $db = Ace->connect(-host=>'brie2.cshl.org',-port=>2005) or die;
my $cosmid = Ace::Sequence->new(-seq=>'Y16B4A',
-db=>$db,-start=>-15000,-end=>15000) or die;
my @transcripts = $cosmid->transcripts;
my $panel = Ace::Graphics::Panel->new(
-segment => $cosmid,
-width => 800
);
$panel->add_track(arrow => $cosmid,
Ace/Graphics/Panel.pm view on Meta::CPAN
Option Value Default
------ ----- -------
-length Length of sequence segment, in bp 0
-segment An Ace::Sequence or Das::Segment none
object, used to derive length if
not provided
-offset Base pair to place at extreme left $segment->start
of image.
-width Desired width of image, in pixels 600
-spacing Spacing between tracks, in pixels 5
-pad_top Additional whitespace between top 0
of image and contents, in pixels
-pad_bottom Additional whitespace between top 0
Ace/Graphics/Track.pm view on Meta::CPAN
Ace::Graphics::Track - PNG graphics of Ace::Sequence::Feature objects
=head1 SYNOPSIS
use Ace::Sequence;
use Ace::Graphics::Panel;
my $db = Ace->connect(-host=>'brie2.cshl.org',-port=>2005) or die;
my $cosmid = Ace::Sequence->new(-seq=>'Y16B4A',
-db=>$db,-start=>-15000,-end=>15000) or die;
my @transcripts = $cosmid->transcripts;
my $panel = Ace::Graphics::Panel->new(
-segment => $cosmid,
-width => 800
);
my $track = $panel->add_track('transcript'
Ace/Graphics/Track.pm view on Meta::CPAN
horizontal band and will not allow any other features to overlap.
=item $track->add_group($group)
This behaves the same as add_feature(), but requires that its argument
be an array reference containing a list of grouped features.
=item $track->draw($gd,$left,$top)
Render the track on a previously-created GD::Image object. The $left
and $top arguments indicate the position at which to start rendering.
=item $boxes = $track->boxes($left,$top)
=item @boxes = $track->boxes($left,$top)
Return an array of array references indicating glyph coordinates for
each of the render features. $left and $top indicate the offset for
the track on the image plane. In a scalar context, this method
returns an array reference of glyph coordinates. In a list context,
it returns the list itself.
Ace/Model.pm view on Meta::CPAN
For example, in the C elegans ?Locus model, the path for 'Compelementation_data"
will return the list ('Type','Gene').
=head2 asString()
print $model->asString;
asString() returns the human-readable representation of the model with
comments stripped out. Internally this method is called to
automatically convert the model into a string when appropriate. You
need only to start performing string operations on the model object in
order to convert it into a string automatically:
print "Paper is unique" if $model=~/Paper ?Paper UNIQUE/;
=head1 SEE ALSO
L<Ace>
=head1 AUTHOR
Ace/Object.pm view on Meta::CPAN
$self->_dirty(1);
}
sub _parse {
my $self = shift;
return unless my $raw = $self->{'.raw'};
my $ts = $self->db->timestamps;
my $col = $self->{'.col'};
my $current_obj = $self;
my $current_row = $self->{'.start_row'};
my $db = $self->db;
my $changed;
for (my $r=$current_row+1; $r<=$self->{'.end_row'}; $r++) {
next unless $raw->[$r][$col] ne '';
$changed++;
my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$r-1,$db);
# comment handling
Ace/Object.pm view on Meta::CPAN
my ($t,$i);
my $row = $current_row + 1;
while ($obj_right->isComment) {
$current_obj->comment($obj_right) if $obj_right->isComment;
$t = $obj_right;
last unless defined($obj_right = $self->_fromRaw($raw,$row++,$col+1,$self->{'.end_row'},$db));
}
}
$current_obj->{'.right'} = $obj_right;
$self->_dirty(1) if $changed;
delete @{$self}{qw[.raw .start_row .end_row .col]};
}
sub _fromRaw {
my $pack = shift;
# this breaks inheritance...
# $pack = $pack->factory();
my ($raw,$start_row,$col,$end_row,$db) = @_;
$db = "$db" if ref $db;
return unless defined $raw->[$start_row][$col];
# HACK! Some LongText entries may begin with newlines. This is within the Acedb spec.
# Let's purge text entries of leading space and format them appropriate.
# This should probably be handled in Freesubs.xs / Ace::split
my $temp = $raw->[$start_row][$col];
# if ($temp =~ /^\?txt\?\s*\n*/) {
# $temp =~ s/^\?txt\?(\s*\\n*)/\?txt\?/;
# $temp .= '?';
# }
my ($class,$name,$ts) = Ace->split($temp);
my $self = $pack->new($class,$name,$db,!($start_row || $col));
@{$self}{qw(.raw .start_row .end_row .col db)} = ($raw,$start_row,$end_row,$col,$db);
$self->{'.timestamp'} = $ts if defined $ts;
return $self;
}
# Return partial ace subtree at indicated tag
sub _at {
my ($self,$tag) = @_;
my $pos=0;
Ace/Object.pm view on Meta::CPAN
my @commands;
if ($view || $c || $self->class =~ /Map/i) {
@commands = "gif map \"@{[$self->name]}\" $view $c";
} else {
@commands = "gif display $display $view @{[$self->class]} \"@{[$self->name]}\"";
}
push(@commands,"Dimensions @$dimensions") if ref($dimensions);
push(@commands,map { "mouseclick @{$_}" } @$clicks) if ref($clicks);
if ($getcoords) { # just want the coordinates
my ($start,$stop);
my $data = $self->db->raw_query(join(' ; ',@commands));
return unless $data =~ /\"[^\"]+\" ([\d.-]+) ([\d.-]+)/;
($start,$stop) = ($1,$2);
return ($start,$stop);
}
push(@commands,"gifdump -");
# do the query
my $data = $self->db->raw_query(join(' ; ',@commands));
# A $' has been removed here to improve speed -- tim.cutts@incyte.com 2 Sep 1999
# did this query succeed?
Ace/Object.pm view on Meta::CPAN
return --$level;
}
# This function is overly long because it is optimized to prevent parsing
# parts of the tree that haven't previously been parsed.
sub _asTable {
my($self,$out,$position,$level) = @_;
do {
if ($self->{'.raw'}) { # we still have raw data, so we can optimize
my ($a,$start,$end) = @{$self}{ qw(.col .start_row .end_row) };
my @to_append = map { join("\t",@{$_}[$a..$#{$_}]) } @{$self->{'.raw'}}[$start..$end];
my $new_row;
foreach (@to_append) {
# hack alert
s/(\?.*?[^\\]\?.*?[^\\]\?)\S*/$self->_ace_format(Ace->split($1))/eg;
if ($new_row++) {
$$out .= "\n";
$$out .= "\t" x ($level-1)
}
$$out .= $_;
}
Ace/Object.pm view on Meta::CPAN
return $p->{'.down'} = $self->new('tag',$tag);
}
# This is unsatisfactory because it duplicates much of the code
# of asTable.
sub _asAce {
my($self,$out,$level,$tags) = @_;
# ugly optimization for speed
if ($self->{'.raw'}){
my ($a,$start,$end) = @{$self}{qw(.col .start_row .end_row)};
my (@last);
foreach (@{$self->{'.raw'}}[$start..$end]){
my $j=1;
$$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags);
my (@to_modify) = @{$_}[$a..$#{$_}];
foreach (@to_modify) {
my ($class,$name) =Ace->split($_);
if (defined($name)) {
$name = $self->_ace_format($class,$name);
if (_isObject($class) || $name=~/[^\w.-]/) {
$name=~s/"/\\"/g; #escape quotes with slashes
$name = qq/\"$name\"/;
Ace/Sequence.pm view on Meta::CPAN
*source_seq = \&source;
*source_tag = \&subtype;
*primary_tag = \&type;
my %plusminus = ( '+' => '-',
'-' => '+',
'.' => '.');
# internal keys
# parent => reference Sequence in "+" strand
# p_offset => our start in the parent
# length => our length
# strand => our strand (+ or -)
# refseq => reference Sequence for coordinate system
# object constructor
# usually called like this:
# $seq = Ace::Sequence->new($object);
# but can be called like this:
# $seq = Ace::Sequence->new(-db=>$db,-name=>$name);
# or
# $seq = Ace::Sequence->new(-seq => $object,
# -offset => $offset,
# -length => $length,
# -ref => $refseq
# );
# $refseq, if provided, will be used to establish the coordinate
# system. Otherwise the first base pair will be set to 1.
sub new {
my $pack = shift;
my ($seq,$start,$end,$offset,$length,$refseq,$db) =
rearrange([
['SEQ','SEQUENCE','SOURCE'],
'START',
['END','STOP'],
['OFFSET','OFF'],
['LENGTH','LEN'],
'REFSEQ',
['DATABASE','DB'],
],@_);
# Object must have a parent sequence and/or a reference
# sequence. In some cases, the parent sequence will be the
# object itself. The reference sequence is used to set up
# the frame of reference for the coordinate system.
# fetch the sequence object if we don't have it already
croak "Please provide either a Sequence object or a database and name"
unless ref($seq) || ($seq && $db);
# convert start into offset
$offset = $start - 1 if defined($start) and !defined($offset);
# convert stop/end into length
$length = ($end > $start) ? $end - $offset : $end - $offset - 2
if defined($end) && !defined($length);
# if just a string is passed, try to fetch a Sequence object
my $obj = ref($seq) ? $seq : $db->fetch('Sequence'=>$seq);
unless ($obj) {
Ace->error("No Sequence named $obj found in database");
return;
}
# get parent coordinates and length of this sequence
Ace/Sequence.pm view on Meta::CPAN
$_[0]->{obj};
}
# return the parent object
sub parent { $_[0]->{parent} }
# return the length
#sub length { $_[0]->{length} }
sub length {
my $self = shift;
my ($start,$end) = ($self->start,$self->end);
return $end - $start + ($end > $start ? 1 : -1); # for stupid 1-based adjustments
}
sub reversed { return shift->strand < 0; }
sub automerge {
my $self = shift;
my $d = $self->{automerge};
$self->{automerge} = shift if @_;
$d;
}
Ace/Sequence.pm view on Meta::CPAN
my $d = $self->{_debug};
$self->{_debug} = shift if @_;
$d;
}
# return the database this sequence is associated with
sub db {
return Ace->name2db($_[0]->{db} ||= $_[0]->source->db);
}
sub start {
my ($self,$abs) = @_;
$abs = $self->absolute unless defined $abs;
return $self->{p_offset} + $self->{offset} + 1 if $abs;
if ($self->refseq) {
my ($ref,$r_offset,$r_strand) = $self->refseq;
return $r_strand < 0 ? 1 + $r_offset - ($self->{p_offset} + $self->{offset})
: 1 + $self->{p_offset} + $self->{offset} - $r_offset;
}
else {
return $self->{offset} +1;
}
}
sub end {
my ($self,$abs) = @_;
my $start = $self->start($abs);
my $f = $self->{length} > 0 ? 1 : -1; # for stupid 1-based adjustments
if ($abs && $self->refseq ne $self->parent) {
my $r_strand = $self->r_strand;
return $start - $self->{length} + $f
if $r_strand < 0 or $self->{strand} < 0 or $self->{length} < 0;
return $start + $self->{length} - $f
}
return $start + $self->{length} - $f if $self->r_strand eq $self->{strand};
return $start - $self->{length} + $f;
}
# turn on absolute coordinates (relative to reference sequence)
sub absolute {
my $self = shift;
my $prev = $self->{absolute};
$self->{absolute} = $_[0] if defined $_[0];
return $prev;
}
# human readable string (for debugging)
sub asString {
my $self = shift;
if ($self->absolute) {
return join '',$self->parent,'/',$self->start,',',$self->end;
} elsif (my $ref = $self->refseq){
my $label = $ref->isa('Ace::Sequence::Feature') ? $ref->info : "$ref";
return join '',$label,'/',$self->start,',',$self->end;
} else {
join '',$self->source,'/',$self->start,',',$self->end;
}
}
sub cmp {
my ($self,$arg,$reversed) = @_;
if (ref($arg) and $arg->isa('Ace::Sequence')) {
my $cmp = $self->parent cmp $arg->parent
|| $self->start <=> $arg->start;
return $reversed ? -$cmp : $cmp;
}
my $name = $self->asString;
return $reversed ? $arg cmp $name : $name cmp $arg;
}
# Return the DNA
sub dna {
my $self = shift;
return $self->{dna} if $self->{dna};
my $raw = $self->_query('seqdna');
$raw=~s/^>.*\n//m;
$raw=~s/^\/\/.*//mg;
$raw=~s/\n//g;
$raw =~ s/\0+\Z//; # blasted nulls!
my $effective_strand = $self->end >= $self->start ? '+1' : '-1';
_complement(\$raw) if $self->r_strand ne $effective_strand;
return $self->{dna} = $raw;
}
# return a gff file
sub gff {
my $self = shift;
my ($abs,$features) = rearrange([['ABS','ABSOLUTE'],'FEATURES'],@_);
$abs = $self->absolute unless defined $abs;
Ace/Sequence.pm view on Meta::CPAN
my %clones;
return unless @clones;
return $self->_make_clones(\@clones);
}
sub _make_clones {
my $self = shift;
my $features = shift;
my (%clones,@canonical_clones);
my $start_label = $self->strand < 0 ? 'end' : 'start';
my $end_label = $self->strand < 0 ? 'start' : 'end';
for my $feature (@$features) {
$clones{$feature->info}{$start_label} = $feature->start if $feature->type eq 'Clone_left_end';
$clones{$feature->info}{$end_label} = $feature->start if $feature->type eq 'Clone_right_end';
if ($feature->type eq 'Sequence') {
my $info = $feature->info;
next if $info =~ /LINK|CHROMOSOME|\.\w+$/;
if ($info->Genomic_canonical(0)) {
push (@canonical_clones,$info->Clone) if $info->Clone;
}
}
}
Ace/Sequence.pm view on Meta::CPAN
if ($abs) {
$r_offset = 0;
$r = $parent;
$r_strand = '+1';
}
# BAD HACK ALERT. WE DON'T KNOW WHERE THE LEFT END OF THE CLONE IS SO WE USE
# THE MAGIC NUMBER -99_999_999 to mean "off left end" and
# +99_999_999 to mean "off right end"
for my $clone (keys %clones) {
my $start = $clones{$clone}{start} || -99_999_999;
my $end = $clones{$clone}{end} || +99_999_999;
my $phony_gff = join "\t",($parent,'Clone','structural',$start,$end,'.','.','.',qq(Clone "$clone"));
push @features,Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$phony_gff);
}
return @features;
}
# Assemble a list of "GappedAlignment" objects. These objects
# contain a list of aligned segments.
sub alignments {
my $self = shift;
my @subtypes = @_;
Ace/Sequence.pm view on Meta::CPAN
return @pieces if @pieces;
return @pieces = $obj->get('Subsequence');
}
# get sequence, offset and strand of topmost container
sub _traverse {
my $obj = shift;
my ($offset,$length);
# invoke seqget to find the top-level container for this sequence
my ($tl,$tl_start,$tl_end) = _get_toplevel($obj);
$tl_start ||= 0;
$tl_end ||= 0;
# make it an object
$tl = ref($obj)->new(-name=>$tl,-class=>'Sequence',-db=>$obj->db);
$offset += $tl_start - 1; # offset to beginning of toplevel
$length ||= abs($tl_end - $tl_start) + 1;
my $strand = $tl_start < $tl_end ? +1 : -1;
return ($tl,$offset,$strand < 0 ? ($length,'-1') : ($length,'+1') ) if $length;
}
sub _get_toplevel {
my $obj = shift;
my $class = $obj->class;
my $name = $obj->name;
my $smap = $obj->db->raw_query("gif smap -from $class:$name");
my ($parent,$pstart,$pstop,$tstart,$tstop,$map_type) =
$smap =~ /^SMAP\s+(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(.+)/;
$parent ||= '';
$parent =~ s/^Sequence://; # remove this in next version of Acedb
return ($parent,$pstart,$pstop);
}
# create subroutine that filters GFF files for certain feature types
sub _make_filter {
my $self = shift;
my $automerge = $self->automerge;
# parse out the filter
my %filter;
foreach (@_) {
Ace/Sequence.pm view on Meta::CPAN
return $data; #blasted nulls!
}
# shortcut for running a gif query
sub _query {
my $self = shift;
my $command = shift;
my $db = shift || $self->db;
my $parent = $self->parent;
my $start = $self->start(1);
my $end = $self->end(1);
($start,$end) = ($end,$start) if $start > $end; #flippity floppity
my $coord = "-coords $start $end";
# BAD BAD HACK ALERT - CHECKS THE QUERY THAT IS PASSED DOWN
# ALSO MAKES THINGS INCOMPATIBLE WITH PRIOR 4.9 servers.
# my $opt = $command =~ /seqfeatures/ ? '-nodna' : '';
my $opt = '-noclip';
my $query = "gif seqget $parent $opt $coord ; $command";
warn $query if $self->debug;
return $db->raw_query("gif seqget $parent $opt $coord ; $command");
Ace/Sequence.pm view on Meta::CPAN
# Wrap it in an Ace::Sequence object
$seq = Ace::Sequence->new($obj);
# Find all the exons
@exons = $seq->features('exon');
# Find all the exons predicted by various versions of "genefinder"
@exons = $seq->features('exon:genefinder.*');
# Iterate through the exons, printing their start, end and DNA
for my $exon (@exons) {
print join "\t",$exon->start,$exon->end,$exon->dna,"\n";
}
# Find the region 1000 kb upstream of the first exon
$sub = Ace::Sequence->new(-seq=>$exons[0],
-offset=>-1000,-length=>1000);
# Find all features in that area
@features = $sub->features;
# Print its DNA
Ace/Sequence.pm view on Meta::CPAN
=head1 Object Methods
Once an I<Ace::Sequence> object is created, you can query it using the
following methods:
=head2 asString()
$name = $seq->asString;
Returns a human-readable identifier for the sequence in the form
I<Source/start-end>, where "Source" is the name of the source
sequence, and "start" and "end" are the endpoints of the sequence
relative to the source (using 1-based indexing). This method is
called automatically when the I<Ace::Sequence> is used in a string
context.
=head2 source_seq()
$source = $seq->source_seq;
Return the source of the I<Ace::Sequence>.
Ace/Sequence.pm view on Meta::CPAN
$refseq = $seq->refseq;
Returns the reference sequence, if one is defined.
$seq->refseq($new_ref);
Set the reference sequence. The reference sequence must share the same
ancestor with $seq.
=head2 start()
$start = $seq->start;
Start of this sequence, relative to the source sequence, using 1-based
indexing.
=head2 end()
$end = $seq->end;
End of this sequence, relative to the source sequence, using 1-based
indexing.
Ace/Sequence.pm view on Meta::CPAN
Where I<type> is the class of the feature (the "feature" field of the
GFF format), and I<subtype> is a description of how the feature was
derived (the "source" field of the GFF format). Either of these
fields can be absent, and either can be a regular expression. More
advanced filtering is not supported, but is provided by the Sanger
Centre's GFF module.
The order of the features in the returned list is not specified. To
obtain features sorted by position, use this idiom:
@features = sort { $a->start <=> $b->start } $seq->features;
=head2 feature_list()
my $list = $seq->feature_list();
This method returns a summary list of the features that cross the
sequence in the form of a L<Ace::Feature::List> object. From the
L<Ace::Feature::List> object you can obtain the list of feature names
and the number of each type. The feature list is obtained from the
ACeDB server with a single short transaction, and therefore has much
Ace/Sequence.pm view on Meta::CPAN
-features => ['exon','intron:GeneFinder']);
This method returns a GFF file as a scalar. The following arguments
are optional:
=over 4
=item -abs
Ordinarily the feature entries in the GFF file will be returned in
coordinates relative to the start of the I<Ace::Sequence> object.
Position 1 will be the start of the sequence object, and the "+"
strand will be the sequence object's natural orientation. However if
a true value is provided to B<-abs>, the coordinate system used will
be relative to the start of the source sequence, i.e. the native ACeDB
Sequence object (usually a cosmid sequence or a link).
If a reference sequence was provided when the I<Ace::Sequence> was
created, it will be used by default to set the coordinate system.
Relative coordinates can be reenabled by providing a false value to
B<-abs>.
Ordinarily the coordinate system manipulations automatically "do what
you want" and you will not need to adjust them. See also the abs()
method described below.
Ace/Sequence/Feature.pm view on Meta::CPAN
'-1' => '+1'); # war is peace, &c.
use overload
'""' => 'asString',
;
# parse a line from a sequence list
sub new {
my $pack = shift;
my ($parent,$ref,$r_offset,$r_strand,$abs,$gff_line,$db) = @_;
my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t",$gff_line;
if (defined($strand)) {
$strand = $strand eq '-' ? '-1' : '+1';
} else {
$strand = 0;
}
# for efficiency/performance, we don't use superclass new() method, but modify directly
# handling coordinates. See SCRAPS below for what should be in here
$strand = '+1' if $strand < 0 && $r_strand < 0; # two wrongs do make a right
($start,$end) = ($end,$start) if $strand < 0;
my $offset = $start - 1;
my $length = ($end > $start) ? $end - $offset : $end - $offset - 2;
# handle negative strands
$offset ||= 0;
$offset *= -1 if $r_strand < 0 && $strand != $r_strand;
my $self= bless {
obj => $ref,
offset => $offset,
length => $length,
parent => $parent,
Ace/Sequence/Feature.pm view on Meta::CPAN
my $self = shift;
my $name = $self->SUPER::asString;
my $type = $self->type;
return "$type:$name";
}
# unique ID
sub id {
my $self = shift;
my $source = $self->source->name;
my $start = $self->start;
my $end = $self->end;
return "$source/$start,$end";
}
# map info into a reasonable set of ace objects
sub toAce {
my $self = shift;
my $thing = shift;
my ($tag,@values) = $thing=~/(\"[^\"]+?\"|\S+)/g;
foreach (@values) { # strip the damn quotes
s/^\"(.*)\"$/$1/; # get rid of leading and trailing quotes
}
Ace/Sequence/Feature.pm view on Meta::CPAN
# Special cases, hardcoded in Ace GFF code...
my $db = $self->db;;
my $class = $db->class;
# for Notes we just return a text, no database associated
return $class->new(Text=>$data[0]) if $tag eq 'Note';
# for homols, we create the indicated Protein or Sequence object
# then generate a bogus Homology object (for future compatability??)
if ($tag eq 'Target') {
my ($objname,$start,$end) = @data;
my ($classe,$name) = $objname =~ /^(\w+):(.+)/;
return Ace::Sequence::Homol->new_homol($classe,$name,$db,$start,$end);
}
# General case:
my $obj = $class->new($tag=>$data[0],$self->db);
return $obj if defined $obj;
# Last resort, return a Text
return $class->new(Text=>$data[0]);
}
Ace/Sequence/Feature.pm view on Meta::CPAN
-offset => 3_000_000,
-length => 1_000_000);
# get all the homologies (a list of Ace::Sequence::Feature objs)
@homol = $seq->features('Similarity');
# Get information about the first one
$feature = $homol[0];
$type = $feature->type;
$subtype = $feature->subtype;
$start = $feature->start;
$end = $feature->end;
$score = $feature->score;
# Follow the target
$target = $feature->info;
# print the target's start and end positions
print $target->start,'-',$target->end, "\n";
=head1 DESCRIPTION
I<Ace::Sequence::Feature> is a subclass of L<Ace::Sequence::Feature>
specialized for returning information about particular features in a
GFF format feature table.
=head1 OBJECT CREATION
You will not ordinarily create an I<Ace::Sequence::Feature> object
Ace/Sequence/Feature.pm view on Meta::CPAN
=item type()
$type = $feature->type;
These two methods are also synonyms. They return the type of the
feature, such as "exon", "similarity" or "Predicted_gene". In the GFF
documentation this is called the "feature" field. For readability,
you can also use type() to fetch the field.
=item abs_start()
$start = $feature->abs_start;
This method returns the absolute start of the feature within the
sequence segment indicated by seqname(). As in the I<Ace::Sequence>
method, use start() to obtain the start of the feature relative to its
source.
=item abs_start()
$start = $feature->abs_start;
This method returns the start of the feature relative to the sequence
segment indicated by seqname(). As in the I<Ace::Sequence> method,
you will more usually use the inherited start() method to obtain the
start of the feature relative to its source sequence (the
I<Ace::Sequence> from which it was originally derived).
=item abs_end()
$start = $feature->abs_end;
This method returns the end of the feature relative to the sequence
segment indicated by seqname(). As in the I<Ace::Sequence> method,
you will more usually use the inherited end() method to obtain the end
of the feature relative to the I<Ace::Sequence> from which it was
derived.
=item score()
$score = $feature->score;
Ace/Sequence/Feature.pm view on Meta::CPAN
field of the GFF format, the so-called "group" field. The type of the
Ace::Object is dependent on the nature of the feature. The
possibilities are shown in the table below:
Feature Type Value of Group Field
------------ --------------------
note A Text object containing the note.
similarity An Ace::Sequence::Homology object containing
the target and its start/stop positions.
intron An Ace::Object containing the gene from
exon which the feature is derived.
misc_feature
other A Text object containing the group data.
=item asString()
$label = $feature->asString;
Returns a human-readable identifier describing the nature of the
feature. The format is:
$type:$name/$start-$end
for example:
exon:ZK154.3/1-67
This method is also called automatically when the object is treated in
a string context.
=back
Ace/Sequence/Feature.pm view on Meta::CPAN
=cut
__END__
# SCRAPS
# the new() code done "right"
# sub new {
# my $pack = shift;
# my ($ref,$r_offset,$r_strand,$gff_line) = @_;
# my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t";
# ($start,$end) = ($end,$start) if $strand < 0;
# my $self = $pack->SUPER::new($source,$start,$end);
# $self->{info} = {
# seqname=> $sourceseq,
# method => $method,
# type => $type,
# score => $score,
# frame => $frame,
# group => $group,
# };
# $self->{fstrand} = $strand;
# return $self;
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
# autoload delegates everything to the Sequence feature
sub AUTOLOAD {
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
my $self = shift;
$self->{base}->$func_name(@_);
}
sub new {
my $class = shift;
my $segments = shift;
my @segments = sort {$a->start <=> $b->start} @$segments;
# find the min and max for the alignment
my ($offset,$len);
if ($segments[0]->start < $segments[-1]->start) { # positive direction
$offset = $segments[0]->{offset};
$len = $segments[-1]->end - $segments[0]->start + 1;
} else {
$offset = $segments[-1]->{offset};
$len = $segments[0]->end - $segments[-1]->start + 1;
}
my $base = { %{$segments[0]} };
$base->{offset} = $offset;
$base->{length} = $len;
bless $base,ref($segments[0]);
return bless {
base => $base,
segments => $segments,
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
my $base = $self->{base};
my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{segments}};
return $self->strand < 0 ? reverse @e : @e;
}
sub merged_segments {
my $self = shift;
return @{$self->{merged_segs}} if exists $self->{merged_segs};
my @segs = sort {$a->start <=> $b->start} $self->segments;
# attempt to merge overlapping segments
my @merged;
for my $s (@segs) {
my $previous = $merged[-1];
if ($previous && $previous->end+1 >= $s->start) {
$previous->{length} = $s->end - $previous->start + 1; # extend
} else {
my $clone = bless {%$s},ref($s);
push @merged,$clone;
}
}
$self->{merged_segs} = \@merged;
return @merged;
}
1;
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
-length => 1_000_000);
# get all the gapped alignments
@alignments = $seq->alignments('EST_GENOME');
# get the aligned segments from the first one
@segs = $alignments[0]->segments;
# get the position of the first aligned segment on the
# source sequence:
($s_start,$s_end) = ($segs[0]->start,$segs[0]->end);
# get the target position for the first aligned segment
($t_start,$t_end) = ($segs[0]->target->start,$segs[0]->target->end);
=head1 DESCRIPTION
Ace::Sequence::GappedAlignment is a subclass of
Ace::Sequence::Feature. It inherits all the methods of
Ace::Sequence::Feature, but adds the ability to retrieve the positions
of the aligned segments. Each segment is an Ace::Sequence::Feature,
from which you can retrieve the source and target coordinates.
=head1 OBJECT CREATION
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
similar segments.
=item relative()
$relative = $gene->relative;
$gene->relative(1);
This turns on and off relative coordinates. By default, the exons and
intron features will be returned in the coordinate system used by the
gene. If relative() is set to a true value, then coordinates will be
expressed as relative to the start of the gene. The first exon will
(usually) be 1.
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,L<Ace::Sequence::Homol>,
L<Ace::Sequence::Feature>, L<Ace::Sequence::FeatureList>, L<GFF>
=head1 AUTHOR
Lincoln Stein <lstein@cshl.org> with extensive help from Jean
Ace/Sequence/Gene.pm view on Meta::CPAN
coding sequence. THIS IS NOT YET IMPLEMENTED.
=item relative()
$relative = $gene->relative;
$gene->relative(1);
This turns on and off relative coordinates. By default, the exons and
intron features will be returned in the coordinate system used by the
gene. If relative() is set to a true value, then coordinates will be
expressed as relative to the start of the gene. The first exon will
(usually) be 1.
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,L<Ace::Sequence::Homol>,
L<Ace::Sequence::Feature>, L<Ace::Sequence::FeatureList>, L<GFF>
=head1 AUTHOR
Lincoln Stein <lstein@cshl.org> with extensive help from Jean
Ace/Sequence/Homol.pm view on Meta::CPAN
# Ace::Sequence::Homol is just like Ace::Object, but has start() and end() methods
package Ace::Sequence::Homol;
use vars '@ISA';
@ISA = 'Ace::Object';
# this was a mistake!
# use overload '""' => 'asString';
# *stop = \&end;
sub new_homol {
my ($pack,$tclass,$tname,$db,$start,$end) = @_;
return unless my $obj = $db->class->new($tclass,$tname,$db,1);
@$obj{'start','end'} = ($start,$end);
return bless $obj,$pack;
}
sub start { return $_[0]->{'start'}; }
sub end { return $_[0]->{'end'}; }
sub stop { return $_[0]->{'end'}; }
# sub _clone {
# my $self = shift;
# my $pack = ref($self);
# return $pack->new($self->db,$self->class,$self->name,$self->start,$self->end);
# }
#sub asString {
# my $n = $_[0]->name;
# "$n/$_[0]->{'start'}-$_[0]->{'end'}";
#}
1;
=head1 NAME
Ace::Sequence::Homol - Temporary Sequence Homology Class
=head1 SYNOPSIS
Ace/Sequence/Homol.pm view on Meta::CPAN
# sort by score
@sorted = sort { $a->score <=> $b->score } @homol;
# the last one has the highest score
$best = $sorted[$#sorted];
# fetch its associated Ace::Sequence::Homol
$homol = $best->target;
# print out the sequence name, DNA, start and end
print $homol->name,' ',$homol->start,'-',$homol->end,"\n";
print $homol->asDNA;
=head1 DESCRIPTION
I<Ace::Sequence::Homol> is a subclass of L<Ace::Object> (B<not>
L<Ace::Sequence>) which is specialized for returning information about
a DNA or protein homology. This is a temporary placeholder for a more
sophisticated homology class which will include support for
alignments.
Ace/Sequence/Homol.pm view on Meta::CPAN
I<Ace::Sequence::Homol> object directly, please consult the source
code for the I<new()> method.
=head1 OBJECT METHODS
Most methods are inherited from I<Ace::Object>. The following
methods are also supported:
=over 4
=item start()
$start = $homol->start;
Returns the start of the area that is similar to the
I<Ace::Sequence::Feature> from which his homology was derived.
Coordinates are relative to the target homology.
=item end()
$end = $homol->end;
Returns the end of the area that is similar to the
I<Ace::Sequence::Feature> from which his homology was derived.
Coordinates are relative to the target homology.
=item asString()
$label = $homol->asString;
Returns a human-readable identifier describing the nature of the
feature. The format is:
$name/$start-$end
for example:
HUMGEN13/1-67
This method is also called automatically when the object is treated in
a string context.
=back
Ace/Sequence/Multi.pm view on Meta::CPAN
# add the secondary databases
$seq->add_secondary($db1,$db2);
# get all the homologies (a list of Ace::Sequence::Feature objs)
@homol = $seq->features('Similarity');
# Get information about the first one -- goes to the correct db
$feature = $homol[0];
$type = $feature->type;
$subtype = $feature->subtype;
$start = $feature->start;
$end = $feature->end;
$score = $feature->score;
# Follow the target
$target = $feature->info;
# print the target's start and end positions
print $target->start,'-',$target->end, "\n";
=head1 DESCRIPTION
I<Ace::Sequence::Multi> transparently combines information stored
about a sequence in a reference database with features tables from any
number of annotation databases. The resulting object can be used just
like an Ace::Sequence object, except that the features remember their
database of origin and go back to that database for information.
This class will only work properly if the reference database and all
Ace/Sequence/Transcript.pm view on Meta::CPAN
coding sequence. THIS IS NOT YET IMPLEMENTED.
=item relative()
$relative = $gene->relative;
$gene->relative(1);
This turns on and off relative coordinates. By default, the exons and
intron features will be returned in the coordinate system used by the
gene. If relative() is set to a true value, then coordinates will be
expressed as relative to the start of the gene. The first exon will
(usually) be 1.
=head1 SEE ALSO
L<Ace>, L<Ace::Object>, L<Ace::Sequence>,L<Ace::Sequence::Homol>,
L<Ace::Sequence::Feature>, L<Ace::Sequence::FeatureList>, L<GFF>
=head1 AUTHOR
Lincoln Stein <lstein@cshl.org> with extensive help from Jean
1.75
1. Fixed a bad bug involving inability to index into portions of the subtree anchored by
numeric 0.
2. Added the -filled argument to autogenerated methods (big win).
3. Added -coordinates and -getcoordinates arguments to asGif() to support scrolling
and zooming images.
1.71
1. Fixed the Ace::Sequence _make_filter() function to respect the value of automerge()
2. Made it possible to change the color of introns and exons depending on curation status
(will need more work)
3. Fixed Ace::Sequence to correctly report start and end of alignment targets when viewed
from the perspective of a reversed reference sequence (order swapped).
1.70 3/5/2001
1. Folded AceBrowser functionality into package.
2. Added GD graphics.
1.69 10/17/2000
1. fixes to url processing
1.67 9/5/2000
1. Many updates to support socket server.
2. find_many() will now be much faster for complex queries.
3. Single-argument shortcut form for connect()
There is also family of CGI scripts that run on top of AcePerl to give
a WebAce-like interface to Ace (it is not as feature-full as WebAce,
but it is probably easier to set up and run). This package is now part
of the AcePerl distribution, but is not installed unless you specifically
request it. See README.ACEBROWSER for details.
INSTALLING THE ACEDB SERVER
See ACEDB.HOWTO in the docs/ directory for instructions on compiling
acedb and installing the server application to start up when needed.
Lincoln Stein
lstein@cshl.org
acebrowser/cgi-bin/generic/acetable view on Meta::CPAN
display_table($NAME," ");
exit 0;
sub display_table {
my ($name,$parms) = @_;
my $obj = $DB->raw_query("table -title -n $name $parms") || AceMissing($name,$parms);
my ($n,$c) = (escape($name),escape($parms));
print
start_html(-Title=>"$name: $parms",
-Style=>STYLE,
-Class=>'tree',
-Bgcolor=>BGCOLOR_TREE),
h1("$name: $parms"),
&show_table($obj),
#$obj->asHTML() || strong('No more text information about this object in the database'),
FOOTER,
end_html;
}
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
-Script => JSCRIPT
);
print_prompt();
AceNotFound() unless $obj;
display_object($obj,$click);
PrintBottom();
sub print_prompt {
print
start_form(-name=>'question'),
table(
TR (th('Name'),td(textfield(-name=>'name')),
th('Class'),td(textfield(-name=>'class',-size=>15,-onChange=>'document.question.submit()')),
td(submit({-style=>'background: white',-name=>'Change'}))),
),
end_form;
}
sub display_object {
my ($obj,$click) = @_;
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
}
# special case for sequences
if (lc($class) eq 'sequence' && $name =~ /SUPERLINK|CHROMOSOME/) {
print h1('This sequence is too large to display. Try a shorter segment.');
return;
}
build_map_navigation_panel($obj,$name,$class) if $class =~ /Map/i;
my $map_start = param('map_start');
my $map_stop = param('map_stop');
my $has_coords = defined $map_start && defined $map_stop;
my $safe_name = $name;
$safe_name=~tr/[a-zA-Z0-9._\-]/_/c;
my $db = Configuration->Name;
$db=~s!^/!!;
my $path = join('/',$db,$class);
umask 002; # want this writable by group
my ($pic,$picroot) = @{Configuration()->Pictures};
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
my $r = Apache->request;
my $subr = $r->lookup_uri($pic ."/");
$picroot = $subr->filename if $subr;
}
mkpath (["$picroot/$path"],0,0777) || AceError("Can't create directory to store image in")
unless -d "$picroot/$path";
# should be some sort of state variable?
$safe_name .= "." . param('click') if param('click');
$safe_name .= ".start=$map_start,stop=$map_stop" if $has_coords;
$safe_name .= ".gif";
my $image_file = "$picroot/$path/$safe_name";
my $image_path = "$pic/$path/$safe_name";
# get the parameters for the image generation
my @clicks = map { [ split('-',$_) ] } split(',',param('click'));
my @param = (-clicks=>\@clicks);
if ($class =~ /Map/) {
push(@param,(-dimensions=>[WIDTH,HEIGHT]));
push(@param,(-coords=>[param('map_start'),param('map_stop')])) if $has_coords;
}
my ($gif,$boxes) = $obj ? $obj->asGif(@param) : ();
unless (-e $image_file && -M $image_file < 0) {
local(*F);
open (F,">$image_file") || AceError("Can't open image file $image_file for writing: $!\n");
print F $gif || unpack("u",ERROR_GIF);
close F;
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
href="$simple_url">)) if $modern;
print qq(<map name="theMap">),join("\n",@lines),qq(</map>),"\n";
}
# special case for maps
# this builds the whole map control/navigation panel
sub build_map_navigation_panel {
my $obj = shift;
my ($name,$class) = @_;
my $map_start = param ('map_start');
my $map_stop = param ('map_stop');
my($start,$stop) = $obj->asGif(-getcoords=>1);
$map_start ||= $start;
$map_stop ||= $stop;
my($min,$max) = get_extremes($obj->db,$name);
# this section is responsible for centering on the place the user clicks
if (param('click')) {
my ($x,$y) = split '-',param('click');
my $pos = $map_start + $y/HEIGHT * ($map_stop - $map_start);
my $offset = $pos - ($map_start + $map_stop)/2;
$map_start += $offset;
$map_stop += $offset;
param('map_start' => $map_start);
param('map_stop' => $map_stop);
Delete('click');
}
my $self = url(-path_info=>1);
my $half = ($map_stop - $map_start)/2;
my $a1 = $map_start - $half;
$a1 = $min if $min > $a1;
my $a2 = $map_stop - ($map_start - $a1);
my $b2 = $map_stop + $half;
$b2 = $max if $b2 > $max;
my $b1 = $b2 - ($map_stop - $map_start);
my $m1 = $map_start + $half/2;
my $m2 = $map_stop - $half/2;
print start_table({-border=>1});
print TR(td({-align=>'CENTER',-class=>'datatitle',-colspan=>2},'Map Control'));
print start_TR();
print td(
table({-border=>0},
TR(td(' '),
td(
$map_start > $min ?
a({-href=>"$self?name=$name;class=$class;map_start=$a1;map_stop=$a2"},
img({-src=>UP_ICON,-align=>'MIDDLE',-border=>0}),' Up')
:
font({-color=>'#A0A0A0'},img({-src=>UP_ICON,-align=>'MIDDLE',-border=>0}),' Up')
),
td(' ')
),
TR(td({-valign=>'CENTER',-align=>'CENTER'},
a({-href=>"$self?name=$name;class=$class;map_start=$a1;map_stop=$b2"},
img({-src=>ZOOMOUT_ICON,-align=>'MIDDLE',-border=>0}),' Shrink')
),
td({-valign=>'CENTER',-align=>'CENTER'},
a({-href=>"$self?name=$name;class=$class;map_start=$min;map_stop=$max"},'WHOLE')
),
td({-valign=>'CENTER',-align=>'CENTER'},
a({-href=>"$self?name=$name;class=$class;map_start=$m1;map_stop=$m2"},
img({-src=>ZOOMIN_ICON,-align=>'MIDDLE',-border=>0}),' Magnify')
)
),
TR(td(' '),
td(
$map_stop < $max ?
a({-href=>"$self?name=$name;class=$class;map_start=$b1;map_stop=$b2"},
img({-src=>DOWN_ICON,-align=>'MIDDLE',-border=>0}),' Down')
:
font({-color=>'#A0A0A0'},img({-src=>DOWN_ICON,-align=>'MIDDLE',-border=>0}),' Down')
),
td(' '))
)
);
print start_td({-rowspan=>2});
print start_form;
print start_p;
print hidden($_) foreach qw(class name);
print 'Show region between: ',
textfield(-name=>'map_start',-value=>sprintf("%.2f",$map_start),-size=>8,-override=>1),
' and ',
textfield(-name=>'map_stop',- value=>sprintf("%.2f",$map_stop),-size=>8,-override=>1),
' ';
print submit('Change');
print end_p;
print end_form;
print end_td(),end_TR(),end_table();
}
sub get_extremes {
acebrowser/cgi-bin/generic/tree view on Meta::CPAN
}
PrintTop($obj);
print_prompt();
AceNotFound() unless $obj;
display_object($obj);
PrintBottom();
sub print_prompt {
print
start_form(-name=>'question'),
table(
TR (th('Name'),td(textfield(-name=>'name')),
th('Class'),td(textfield(-name=>'class',-size=>15,-onChange=>'document.question.submit()')),
td(submit({-style=>'background: white',-name=>'Change'}))),
),
end_form;
}
sub display_object {
my $obj = shift;
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
}
PrintTop(undef,undef,'Feedback Page');
if (Configuration->Feedback_recipients) {
@FEEDBACK_RECIPIENTS = @{Configuration->Feedback_recipients};
if (param('submit') && send_mail($object_name,$object_class,$where_from)) {
print_confirmation();
} else {
print start_form;
print_instructions();
print_form( $object_name,$object_class,DB_Name(),$where_from );
print end_form;
}
} else {
print p("No recipients for feedback are defined.");
print start_form(),
hidden(-name=>'referer',-value=>$where_from),br,
submit(-name=>'return',-value=>'Cancel & Return',-class=>'error'),
end_form();
}
PrintBottom;
sub print_top {
my $title = 'Data Submissions and Comments';
print start_html (
'-Title' => $title,
'-style' => Style(),
),
Header,
h1($title);
}
sub print_instructions {
my @defaults;
for (my $i=0; $i<@FEEDBACK_RECIPIENTS; $i++) {
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
}
return 1;
}
sub print_confirmation {
print
p("Thank you for taking the time to submit this information.",
"Please use the buttons below to submit more reports or to",
"return to the database.",
),
start_form,
submit(-name=>'restart',-label=>'Submit Another Report'),
hidden('referer'),
submit(-name=>'return',-label=>'Return to Database'),
end_form;
}
acebrowser/cgi-bin/misc/privacy view on Meta::CPAN
#!/usr/bin/perl
# -*- Mode: perl -*-
# file: privacy
# Privacy statement
use strict;
use Ace::Browser::AceSubs;
use CGI 2.42 qw/redirect h1 start_form end_form start_html hidden submit param referer p/;
my $where_from = param('referer') || referer();
if (param('return') && $where_from !~ /\/privacy/ ) {
print redirect($where_from);
exit 0;
}
PrintTop(undef,undef,'Privacy Statement');
print
acebrowser/cgi-bin/misc/privacy view on Meta::CPAN
"This is done in order to track usage statistics",
"and to identify operational problems. This information is not used",
"to identify individuals or organizations, and is never shared with third",
"parties."
),
p(
"Cookies are used by the search pages in order to bookmark your search",
"requests. They do not persist after you exit the browser, and are never",
"used for identification or tracking purposes."
),
start_form,
hidden(-name=>'referer',-value=>$where_from),
submit(-name=>'return',-label=>'Return to Database'),
end_form;
PrintBottom();
acebrowser/cgi-bin/moviedb/movie view on Meta::CPAN
PrintTop($movie,'Movie');
print_prompt();
AceNotFound() unless $movie;
print_report($movie);
PrintBottom();
exit 0;
sub print_prompt {
print
start_form(),
p("Database ID",
textfield(-name=>'name'),
hidden(class=>'Movie'),
),
end_form;
}
sub print_report {
my $movie = shift;
acebrowser/cgi-bin/moviedb/person view on Meta::CPAN
my $person = GetAceObject();
PrintTop($person,'Person');
print_prompt();
AceNotFound() unless $person;
print_report($person);
PrintBottom();
sub print_prompt {
print
start_form({-name=>'form1',-action=>Url(url(-relative=>1))}),
p("Database ID",
hidden(class=>'Person'),
textfield(-name=>'name')
),
end_form;
}
sub print_report {
my $person = shift;
( run in 0.500 second using v1.01-cache-2.11-cpan-0d8aa00de5b )