AcePerl
view release on metacpan or search on metacpan
my $r = $self->raw_query("aql -j $query");
if ($r =~ /(AQL error.*)/) {
$self->error($1);
return;
}
my @r;
foreach (split "\n",$r) {
next if m!^//!;
next if m!^\0!;
my ($class,$id) = Ace->split($_);
my @objects = map { $self->class_for($class,$id)->new(Ace->split($_),$self,1)} split "\t";
push @r,\@objects;
}
return @r;
}
# Return the contents of a keyset. Pattern matches are allowed, in which case
# the keysets will be merged.
sub keyset {
my $self = shift;
my $pattern = shift;
AceDB database. To establish a connection to an AceDB server, use the
B<-host> and/or B<-port> arguments. For a local server, use the
B<-port> argument. The database must be up and running on the
indicated host and port prior to connecting to an AceDB server. The
full syntax is as follows:
$db = Ace->connect(-host => $host,
-port => $port,
-path => $database_path,
-program => $local_connection_program
-classmapper => $object_class,
-timeout => $timeout,
-query_timeout => $query_timeout
-cache => {cache parameters},
);
The connect() method uses a named argument calling style, and
recognizes the following arguments:
=over 4
should point to an executable on your system. You may use either a
complete path or a bare command name, in which case the PATH
environment variable will be consulted. For example, you could force
AcePerl to use the I<aceclient> program to connect to the remote host
by connecting this way:
$db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr',
-port => 20000100,
-program=>'aceclient');
=item B<-classmapper>
The optional B<-classmapper> argument (alias B<-class>) points to the
class you would like to return from database queries. It is provided
for your use if you subclass Ace::Object. For example, if you have
created a subclass of Ace::Object called Ace::Object::Graphics, you
can have the database return this subclass by default by connecting
this way:
$db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr',
-port => 20000100,
-class=>'Ace::Object::Graphics');
Ace/Browser/AceSubs.pm view on Meta::CPAN
=cut
sub AceAddCookie {
push @COOKIES,@_; # add caller's to our globals
}
################## canned header ############
sub AceHeader {
my %searches = map {$_=>1} Configuration()->searches;
my $quovadis = url(-relative=>1);
my $db = get_symbolic();
my $referer = referer();
$referer =~ s!^http://[^/]+!! if defined $referer;
my $home = Configuration()->Home->[0] if Configuration()->Home;
if ($referer && $home && index($referer,$home) >= 0) {
my $bookmark = cookie(
Ace/Browser/AceSubs.pm view on Meta::CPAN
# Subroutines used by all scripts.
# Will generate an HTTP 'document not found' error if you try to get an
# undefined database name. Check the return code from this function and
# return immediately if not true (actually, not needed because we exit).
sub AceInit {
$HEADER = 0;
$TOP = 0;
@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'),
Ace/Browser/AceSubs.pm view on Meta::CPAN
Footer(),
end_html();
return;
}
PrintTop(undef,undef,'Multiple Choices');
print
p("Multiple $report objects correspond to $symbol.",
"Please choose one:"),
ol(
li([
map {ObjectLink($_,font({-color=>'red'},$_->class).': '.$_)} @$objects
])
);
PrintBottom();
}
=item AceNotFound([$class,$name])
This subroutine will print out an error message indicating that the
requested object is not present in AceDB, even as a name. It will then
exit the script. If the class and name of the object are not provided
Ace/Browser/AceSubs.pm view on Meta::CPAN
returns an AceBrowser URL. The URL chosen is determined by the
configuration settings.
It is also possible to pass Object2URL an object name and class, in
the case that an AceDB object isn't available.
The return value is a URL.
=cut
# general mapping from a display to a url
sub Object2URL {
my ($object,$extra) = @_;
my ($name,$class);
if (ref($object)) {
($name,$class) = ($object,$object->class);
} else {
($name,$class) = ($object,$extra);
}
my $display = url(-relative=>1);
my ($disp,$parameters) = Configuration()->map_url($display,$name,$class);
return $disp unless $parameters;
return Url($disp,$parameters);
}
=item $link = ObjectLink($object [,$link_text])
This function converts an AceDB object into a hypertext link. The
first argument is an Ace::Object. The second, optional argument is
the text to use for the link. If not provided, the object's name
becomes the link text.
Ace/Browser/SearchSubs.pm view on Meta::CPAN
-total => \$count
);
AceResultsTable(\@objs,$count,$offset,'Here are the results');
=cut
sub AceResultsTable {
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();
Ace/Browser/SiteDefs.pm view on Meta::CPAN
=head1 SYNOPSIS
use Ace;
use Ace::Browser::AceSubs;
use CGI qw(:standard);
my $configuration = Configuration;
my $docroot = $configuration->Docroot;
my @pictures = @{$configuration->Pictures};
my %displays = %{$configuration->Displays};
my $coderef = $configuration->Url_mapper;
$coderef->($param1,$param2);
=head1 DESCRIPTION
Ace::Browser::SiteDefs evaluates an AceBrowser configuration file and
returns a configuration object ("config object" for short). A config
object is a bag of dynamically-generated methods, derived from the
scalar variables, arrays, hashes and subroutines in the configuration
file.
Ace/Browser/SiteDefs.pm view on Meta::CPAN
croak "Unknown field \"$func_name\"" unless $func_name =~ /^[A-Z]/;
return $self->{$func_name} = $_[0] if defined $_[0];
return $self->{$func_name} if defined $self->{$func_name};
# didn't find it, so get default
return if (my $dflt = $pack->getConfig('default')) == $self;
return $dflt->{$func_name};
}
sub DESTROY { }
sub map_url {
my $self = shift;
my ($display,$name,$class) = @_;
$class ||= $name->class if ref($name) and $name->can('class');
my (@result,$url);
if (my $code = $self->Url_mapper) {
if (@result = $code->($display,$name,$class)) {
return @result;
}
}
# if we get here, then take the first display
my @displays = $self->displays($class,$name);
push @displays,$self->displays('default') unless @displays;
my $n = CGI::escape($name);
my $c = CGI::escape($class);
return ($displays[0],"name=$n;class=$c") if $displays[0];
return unless @result = $self->getConfig('default')->Url_mapper->($display,$name,$class);
return unless $url = $self->display($result[0],'url');
return ($url,$result[1]);
}
sub searches {
my $self = shift;
return unless my $s = $self->Searches;
return @{$s} unless defined $_[0];
return $self->Search_titles->{$_[0]};
}
Ace/Browser/SiteDefs.pm view on Meta::CPAN
}
sub class2displays {
my $self = shift;
my ($class,$name) = @_;
# No class specified. Return name of all defined classes.
return $self->displays unless defined $class;
# A class is specified. Map it into the list of display records.
my @displays = map {$self->display($_)} $self->displays($class,$name);
return @displays;
}
sub _load {
my $package = shift;
my $file = shift;
no strict 'vars';
no strict 'refs';
$file =~ m!([/a-zA-Z0-9._-]+)!;
Ace/Browser/SiteDefs.pm view on Meta::CPAN
*symbol = ${"${namespace}::"}{$_};
$data{ucfirst(lc $_)} = $symbol if defined($symbol);
$data{ucfirst(lc $_)} = \%symbol if defined(%symbol);
$data{ucfirst(lc $_)} = \@symbol if defined(@symbol);
$data{ucfirst(lc $_)} = \&symbol if defined(&symbol);
undef *symbol unless defined &symbol; # conserve some memory
}
# special case: get the search scripts as both an array and as a hash
if (my @searches = @{"$namespace\:\:SEARCHES"}) {
$data{Searches} = [ @searches[map {2*$_} (0..@searches/2-1)] ];
%{$data{Search_titles}} = @searches;
}
# return this thing as a blessed object
return bless \%data,$package;
}
sub resolvePath {
my $self = shift;
my $file = shift;
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;
my $label_width = $self->font->width * CORE::length $label;
my $label_end = $left + $label_width;
$val = $label_end if $label_end > $val;
}
$val;
}
sub map_pt {
my $self = shift;
my $point = shift;
$point -= $self->offset;
my $val = $self->{left} + $self->scale * $point;
my $right = $self->{left} + $self->width;
$val = -1 if $val < 0;
$val = $self->width if $right && $val > $right;
return int $val;
}
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;
$y2 = $y1 if $y2-$y1 < 1;
return ($x1,$y1,$x2,$y2);
Ace/Graphics/Glyph.pm view on Meta::CPAN
Draw the label for the glyph onto the provided GD::Image object,
optionally offsetting by the amounts indicated in $left and $right.
=back
These methods are useful utility routines:
=over 4
=item $pixels = $glyph->map_pt($bases);
Map the indicated base position, given in base pair units, into
pixels, using the current scale and glyph position.
=item $glyph->filled_box($gd,$x1,$y1,$x2,$y2)
Draw a filled rectangle with the appropriate foreground and fill
colors, and pen width onto the GD::Image object given by $gd, using
the provided rectangle coordinates.
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
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
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) {
my $tickpos = $left + $self->map_pt($i);
$gd->line($tickpos,$gtop,$tickpos,$gbottom,$gcolor) if defined $gcolor;
$gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
}
}
for (my $i = $first_tick; $i < $self->end; $i += $interval) {
my $tickpos = $left + $self->map_pt($i);
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);
}
}
$gd->line($x1,$center,$x2,$center,$fg);
if ($sw) { # west arrow
$gd->line($x1,$center,$x1+$a2,$center-$a2,$fg);
Ace/Graphics/Glyph/graded_segments.pm view on Meta::CPAN
# 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
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];
}
}
Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN
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;
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
Returns the desired foreground color for the glyphs in the form of an
GD::Image color index. This may be the one of the special colors
gdBrushed and gdStyled. This is only useful while the enclosing
Ace::Graphics::Panel object is rendering the object. In other
contexts it returns undef.
=item $scale = $factory->scale([$scale])
Get or set the scale, in pixels/bp, for the glyph. This is
ordinarily set by the Ace::Graphics::Track object just prior to
rendering, and called by each glyphs' map_pt() method when performing
the rendering.
=item $color = $factory->bgcolor([$color])
Get or set the background color for the glyphs.
=item $color = $factory->fillcolor([$color])
Get or set the fill color for the glyphs.
Ace/Graphics/Panel.pm view on Meta::CPAN
objects.
Typically you will begin by creating a new Ace::Graphics::Panel
object, passing it the width of the visual display and the length of
the segment.
You will then call add_track() one or more times to add sets of
related features to the picture. When you have added all the features
you desire, you may call png() to convert the image into a PNG-format
image, or boxes() to return coordinate information that can be used to
create an imagemap.
Note that this modules depends on GD.
=head1 METHODS
This section describes the class and object methods for
Ace::Graphics::Panel.
=head2 CONSTRUCTORS
Ace/Graphics/Panel.pm view on Meta::CPAN
=item $png = $panel->png
The png() method returns the image as a PNG-format drawing, without
the intermediate step of returning a GD::Image object.
=item $boxes = $panel->boxes
=item @boxes = $panel->boxes
The boxes() method returns the coordinates of each glyph, useful for
constructing an image map. In a scalar context, boxes() returns an
array ref. In an list context, the method returns the array directly.
Each member of the list is an anonymous array of the following format:
[ $feature, $x1, $y1, $x2, $y2 ]
The first element is the feature object; either an
Ace::Sequence::Feature, a Das::Segment::Feature, or another Bioperl
Bio::SeqFeatureI object. The coordinates are the topleft and
bottomright corners of the glyph, including any space allocated for
Ace/Graphics/Track.pm view on Meta::CPAN
my $self = shift;
my $force = shift || 0;
return $self->{glyphs} if $self->{glyphs} && !$force;
my $f = $self->{features};
my $factory = $self->factory;
$factory->scale($self->scale); # set the horizontal scale
$factory->width($self->width);
# create singleton glyphs
my @singletons = map { $factory->glyph($_) } @$f;
# create linked groups of glyphs
my @groups;
if (my $groups = $self->{group_ids}) {
my $groupfactory = Ace::Graphics::GlyphFactory->new('group');
for my $g (values %$groups) {
my @g = map { $factory->glyph($_) } @$g;
push @groups,$groupfactory->glyph(\@g);
}
}
return $self->{glyphs} = [] unless @singletons || @groups;
# run the bumper on the groups
$self->_bump([@singletons,@groups]) if $self->bump;
# merge the singletons and groups and sort them horizontally
my @glyphs = sort {$a->left <=> $b->left } @singletons,map {$_->members} @groups;
# If -1 bumping was allowed, then normalize so that the top glyph is at zero
my ($topmost) = sort {$a->top <=> $b->top} @glyphs;
my $offset = 0 - $topmost->top;
$_->move(0,$offset) foreach @glyphs;
$self->{groups} = \@groups;
return $self->{glyphs} = \@glyphs;
}
Ace/Model.pm view on Meta::CPAN
my ($name) = $data =~ /\A[\?\#](\w+)/;
my $self = bless {
name => $name,
raw => $data,
submodels => [],
},$class;
if (!$break_cycle->{$name} && $db && (my @hashes = grep {$_ ne $name} $data =~ /\#(\S+)/g)) {
$break_cycle->{$name}++;
my %seen;
my @submodels = map {$db->model($_,$break_cycle)} grep {!$seen{$_}++} @hashes;
$self->{submodels} = \@submodels;
}
return $self;
}
sub name {
return shift()->{name};
}
# return all the tags in the model as a hashref.
# in a list context returns the tags as a long list result
sub tags {
my $self = shift;
$self->{tags} ||= { map {lc($_)=>1}
grep {!/^[\#\?]/o}
grep {!/$KEYWORD/o}
$self->{raw}=~m/(\S+)/g,
map {$_->tags} @{$self->{submodels}}
};
return wantarray ? keys %{$self->{tags}} : $self->{tags};
}
# return the path to a particular tag
sub path {
my $self = shift;
my $tag = lc shift;
$self->parse;
return unless exists $self->{path}{$tag};
Ace/Object.pm view on Meta::CPAN
my $tag = shift unless $_[0]=~/^-/;
my ($subtag,$pos,$filled) = rearrange(['SUBTAG','POS',['FILL','FILLED']],@_);
my $lctag = lc $tag;
# With caching, the old way of following ends up cloning the object
# -- which we don't want. So more-or-less emulate the earlier
# behavior with an explicit get and fetch
# return $self->follow(-tag=>$tag,-filled=>$filled) if $filled;
if ($filled) {
my @node = $self->search($tag) or return; # watch out for recursion!
my @obj = map {$_->fetch} @node;
foreach (@obj) {$_->right if defined $_}; # trigger a fill
return wantarray ? @obj : $obj[0];
}
TRY: {
# look in our tag cache first
if (exists $self->{'.PATHS'}) {
# we've already cached the desired tree
Ace/Object.pm view on Meta::CPAN
return unless defined $_[0];
$_[0] !~ /^(float|int|date|tag|txt|peptide|dna|scalar|[Tt]ext|comment)$/;
}
# utility routine used to split a tag path into individual components
# allows components to contain dots.
sub _split_tags {
my $self = shift;
my $tag = shift;
$tag =~ s/\\\./$;/g; # protect backslashed dots
return map { (my $x=$_)=~s/$;/./g; $x } split(/\./,$tag);
}
1;
__END__
=head1 NAME
Ace::Object - Manipulate Ace Data Objects
Ace/Object.pm view on Meta::CPAN
It is important to note that B<get()> only traverses tags. It will
not traverse nodes that aren't tags, such as strings, integers or
objects. This is in keeping with the behavior of the Ace query
language "show" command.
This restriction can lead to confusing results. For example, consider
the following object:
Clone: B0280 Position Map Sequence-III Ends Left 3569
Right 3585
Pmap ctg377 -1040 -1024
Positive Positive_locus nhr-10
Sequence B0280
Location RW
FingerPrint Gel_Number 0
Canonical_for T20H1
K10E5
Bands 1354 18
The following attempt to fetch the left and right positions of the
Ace/Object.pm view on Meta::CPAN
The module attempts to autogenerate data access methods as needed.
For example, if you refer to a method named "Fax" (which doesn't
correspond to any of the built-in methods), then the code will call
the B<get()> method to find a tag named "Fax" and return its
contents.
Unlike get(), this method will B<always step into objects>. This
means that:
$map = $clone->Map;
will return the Sequence_Map object pointed to by the Clone's Map tag
and not simply a pointer to a portion of the Clone tree. Therefore
autogenerated methods are functionally equivalent to the following:
$map = $clone->get('Map')->fetch;
The scalar context semantics are also slightly different. In a scalar
context, the autogenerated function will *always* move one step to the
right.
The list context semantics are identical to get(). If you want to
dereference all members of a multivalued tag, you have to do so manually:
@papers = $author->Paper;
foreach (@papers) {
Ace/Object.pm view on Meta::CPAN
display for the object. For example, Clones can be displayed either
with the PMAP display or with the TREE display. If not specified, the
default display is used.
The optional B<-view> argument allows you to specify an alternative
view for MAP objects only. If not specified, you'll get the default
view.
The option B<-coords> argument allows you to provide the top and
bottom of the display for MAP objects only. These coordinates are in
the map's native coordinate system (cM, bp). By default, AceDB will
show most (but not necessarily all) of the map according to xace's
display rules. If you call this method with the B<-getcoords>
argument and a true value, it will return a two-element array
containing the coordinates of the top and bottom of the map.
asGIF() returns a two-element array. The first element is the GIF
data. The second element is an array reference that indicates special
areas of the image called "boxes." Boxes are rectangular areas that
surround buttons, and certain displayed objects. Using the contents
of the boxes array, you can turn the GIF image into a client-side
image map. Unfortunately, not everything that is clickable is
represented as a box. You still have to pass clicks on unknown image
areas back to the server for processing.
Each box in the array is a hash reference containing the following
keys:
'coordinates' => [$left,$top,$right,$bottom]
'class' => object class or "BUTTON"
'name' => object name, if any
'comment' => a text comment of some sort
Ace/Object.pm view on Meta::CPAN
my(@lines) = split("\n",$tabs);
my($result,@max);
foreach (@lines) {
my(@fields) = split("\t");
for (my $i=0;$i<@fields;$i++) {
$max[$i] = length($fields[$i]) if
!defined($max[$i]) or $max[$i] < length($fields[$i]);
}
}
foreach (@max) { $_ = $MAXWIDTH if $_ > $MAXWIDTH; } # crunch long lines
my $format1 = join(' ',map { "^"."<"x $max[$_] } (0..$#max)) . "\n";
my $format2 = ' ' . join(' ',map { "^"."<"x ($max[$_]-1) } (0..$#max)) . "~~\n";
$^A = '';
foreach (@lines) {
my @data = split("\t");
push(@data,('')x(@max-@data));
formline ($format1,@data);
formline ($format2,@data);
}
return ($result = $^A,$^A='')[0];
}
Ace/Object.pm view on Meta::CPAN
'GETCOORDS',
],@_);
$display = "-D $display" if $display;
$view = "-view $view" if $view;
my $c;
if ($coords) {
$c = ref($coords) ? "-coords @$coords" : "-coords $coords";
}
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 -");
Ace/Object.pm view on Meta::CPAN
}
################# add a new row #############
# Only changes local copy until you perform commit() #
# returns true if this is a valid thing to do #
sub add_row {
my $self = shift;
my($tag,@newvalue) = rearrange([['TAG','PATH'],'VALUE'],@_);
# flatten array refs into array
my @values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } @newvalue;
# make sure that this entry doesn't already exist
unless ($tag =~ /\./) {
my $model = $self->model;
my @intermediate_tags = $model->path($tag);
$tag = join '.',@intermediate_tags,$tag;
}
my $row = join(".",($tag,map { (my $x = $_) =~s/\./\\./g; $x } @values));
return if $self->at($row); # an identical row already exists in the object
# If we get here then we need to turn @values into an array of Ace::Objects
# for insertion. Also need to link them together into a row.
my $previous;
foreach (@values) {
if (ref($_) && $_->isa('Ace::Object')) {
$_ = $_->_clone;
} else {
$_ = $self->new('scalar',$_);
Ace/Object.pm view on Meta::CPAN
$p = $p->{'.right'};
while (1) {
last unless $p->{'.down'};
$p = $p->{'.down'};
}
$p->{'.down'} = $values[0];
} else {
$p->{'.right'} = $values[0];
}
push(@{$self->{'.update'}},join(' ',map { Ace->freeprotect($_) } (@tags,@values)));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(1);
1;
}
# Use this method to add an entire subobject to the right of the tag.
# The tree may come from another database.
sub add_tree {
my $self = shift;
my($tag,$value,@rest) = rearrange([['TAG','PATH'],['VALUE','TREE']],@_);
Ace/Object.pm view on Meta::CPAN
if ($p->{'.right'}) {
$p = $p->{'.right'};
while (1) {
last unless $p->{'.down'};
$p = $p->{'.down'};
}
$p->{'.down'} = $value->{'.right'};
} else {
$p->{'.right'} = $value->{'.right'};
}
push(@{$self->{'.update'}},map { join(' ',@tags,$_) } split("\n",$value->asAce));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(1);
1;
}
################# delete a portion of the tree #############
# Only changes local copy until you perform commit() #
# returns true if this is a valid thing to do.
sub delete {
my $self = shift;
my($tag,$oldvalue,@rest) = rearrange([['TAG','PATH'],['VALUE','OLDVALUE','OLD']],@_);
# flatten array refs into array
my @values;
@values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } ($oldvalue,@rest)
if defined($oldvalue);
unless ($tag =~ /\./) {
my $model = $self->model;
my @intermediate_tags = $model->path($tag);
$tag = join '.',@intermediate_tags,$tag;
}
my $row = join(".",($tag,map { (my $x = $_) =~s/\./\\./g; $x } @values));
my $subtree = $self->at($row,undef,1); # returns the parent
if (@values
&& defined($subtree->{'.right'})
&& "$subtree->{'.right'}" eq $oldvalue) {
$subtree->{'.right'} = $subtree->{'.right'}->down;
} else {
$subtree->{'.down'} = $subtree->{'.down'}->{'.down'}
}
push(@{$self->{'.update'}},join(' ','-D',
map { Ace->freeprotect($_) } ($self->_split_tags($tag),@values)));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(0);
$self->db->file_cache_delete($self);
1;
}
################# delete a portion of the tree #############
# Only changes local copy until you perform commit() #
# returns true if this is a valid thing to do #
Ace/Object.pm view on Meta::CPAN
}
# 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/Sequence.pm view on Meta::CPAN
my ($parent,$p_offset,$p_length,$strand) = find_parent($obj);
return unless $parent;
# handle negative strands
my $r_strand = $strand;
my $r_offset = $p_offset;
$offset ||= 0;
$offset *= -1 if $strand < 0;
# handle feature objects
$offset += $obj->offset if $obj->can('smapped');
# get source
my $source = $obj->can('smapped') ? $obj->source : $obj;
# store the object into our instance variables
my $self = bless {
obj => $source,
offset => $offset,
length => $length || $p_length,
parent => $parent,
p_offset => $p_offset,
refseq => [$source,$r_offset,$r_strand],
strand => $strand,
Ace/Sequence.pm view on Meta::CPAN
my $arrayref;
BLOCK: {
last BLOCK unless defined ($refseq);
if (ref($refseq) && ref($refseq) eq 'ARRAY') {
$arrayref = $refseq;
last BLOCK;
}
if (ref($refseq) && ($refseq->can('smapped'))) {
croak "Reference sequence has no common ancestor with sequence"
unless $self->parent eq $refseq->parent;
my ($a,$b,$c) = @{$refseq->{refseq}};
# $b += $refseq->offset;
$b += $refseq->offset;
$arrayref = [$refseq,$b,$refseq->strand];
last BLOCK;
}
Ace/Sequence.pm view on Meta::CPAN
if (my ($ref,$r_offset,$r_strand) = $self->refseq) {
return $r_strand;
} else {
return $self->{strand}
}
}
sub offset { $_[0]->{offset} }
sub p_offset { $_[0]->{p_offset} }
sub smapped { 1; }
sub type { 'Sequence' }
sub subtype { }
sub debug {
my $self = shift;
my $d = $self->{_debug};
$self->{_debug} = shift if @_;
$d;
}
Ace/Sequence.pm view on Meta::CPAN
my ($filter,$opt) = $self->_make_filter(@_);
# get raw gff file
my $gff = $self->gff(-features=>$opt);
# turn it into a list of features
my @features = $self->_make_features($gff,$filter);
if ($self->automerge) { # automatic merging
# fetch out constructed transcripts and clones
my %types = map {lc($_)=>1} (@$opt,@_);
if ($types{'transcript'}) {
push @features,$self->_make_transcripts(\@features);
@features = grep {$_->type !~ /^(intron|exon)$/ } @features;
}
push @features,$self->_make_clones(\@features) if $types{'clone'};
if ($types{'similarity'}) {
my @f = $self->_make_alignments(\@features);
@features = grep {$_->type ne 'similarity'} @features;
push @features,@f;
}
Ace/Sequence.pm view on Meta::CPAN
} elsif ($feature->type eq 'Sequence') {
$transcripts{$transcript}{base} ||= $feature;
}
}
# get rid of transcripts without exons
foreach (keys %transcripts) {
delete $transcripts{$_} unless exists $transcripts{$_}{exon}
}
# map the rest onto Ace::Sequence::Transcript objects
return map {Ace::Sequence::Transcript->new($transcripts{$_})} keys %transcripts;
}
# Reassemble clones from clone left and right ends
sub clones {
my $self = shift;
my @clones = $self->features('Clone_left_end','Clone_right_end','Sequence');
my %clones;
return unless @clones;
return $self->_make_clones(\@clones);
}
Ace/Sequence.pm view on Meta::CPAN
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 = @_;
my @types = map { "similarity:\^$_\$" } @subtypes;
push @types,'similarity' unless @types;
return $self->features(@types);
}
sub segments {
my $self = shift;
return;
}
sub _make_alignments {
Ace/Sequence.pm view on Meta::CPAN
my %homol;
for my $feature (@$features) {
next unless $feature->type eq 'similarity';
my $target = $feature->info;
my $subtype = $feature->subtype;
push @{$homol{$target,$subtype}},$feature;
}
# map onto Ace::Sequence::GappedAlignment objects
return map {Ace::Sequence::GappedAlignment->new($homol{$_})} keys %homol;
}
# return list of features quickly
sub feature_list {
my $self = shift;
return $self->{'feature_list'} if $self->{'feature_list'};
return unless my $raw = $self->_query('seqfeatures -version 2 -list');
return $self->{'feature_list'} = Ace::Sequence::FeatureList->new($raw);
}
Ace/Sequence.pm view on Meta::CPAN
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;
Ace/Sequence.pm view on Meta::CPAN
my ($gff,$filter) = @_;
my ($r,$r_offset,$r_strand) = $self->refseq;
my $parent = $self->parent;
my $abs = $self->absolute;
if ($abs) {
$r_offset = 0;
$r = $parent;
$r_strand = '+1';
}
my @features = map {Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$_)}
grep !m@^(?:\#|//)@ && $filter->($_),split("\n",$gff);
}
# low level GFF call, no changing absolute to relative coordinates
sub _gff {
my $self = shift;
my ($opt,$db) = @_;
my $data = $self->_query("seqfeatures -version 2 $opt",$db);
$data =~ s/\0+\Z//;
Ace/Sequence.pm view on Meta::CPAN
initially passed to the new() method. However, there are exceptions
to this rule. One common exception occurs when the offset and/or
length cross the boundaries of the passed-in sequence. In this case,
the ACeDB database is searched for the smallest sequence that contains
both endpoints of the I<Ace::Sequence> object.
The other common exception occurs in Ace 4.8, where there is support
for "sequence-like" objects that contain the C<SMap> ("Sequence Map")
tag. The C<SMap> tag provides genomic location information for
arbitrary object -- not just those descended from the Sequence class.
This allows ACeDB to perform genome map operations on objects that are
not directly related to sequences, such as genetic loci that have been
interpolated onto the physical map. When an C<SMap>-containing object
is passed to the I<Ace::Sequence> new() method, the module will again
choose the smallest ACeDB Sequence object that contains both
end-points of the desired region.
If an I<Ace::Sequence> object is used to create a new I<Ace::Sequence>
object, then the original object's source is inherited.
=head1 Object Methods
Once an I<Ace::Sequence> object is created, you can query it using the
Ace/Sequence/Feature.pm view on Meta::CPAN
type => $type,
score => $score,
frame => $frame,
group => $group,
db => $db,
}
},$pack;
return $self;
}
sub smapped { 1; }
# $_[0] is field name, $_[1] is self, $_[2] is optional replacement value
sub _field {
my $self = shift;
my $field = shift;
my $v = $self->{info}{$field};
$self->{info}{$field} = shift if @_;
return if defined $v && $v eq '.';
return $v;
}
Ace/Sequence/Feature.pm view on Meta::CPAN
sub type { shift->_field('type',@_) } # ... I prefer "type"
sub score { shift->_field('score',@_) } # float indicating some sort of score
sub frame { shift->_field('frame',@_) } # one of 1, 2, 3 or undef
sub info { # returns Ace::Object(s) with info about the feature
my $self = shift;
unless ($self->{group}) {
my $info = $self->{info}{group} || 'Method "'.$self->method.'"';
$info =~ s/(\"[^\"]*);([^\"]*\")/$1$;$2/g;
my @data = split(/\s*;\s*/,$info);
foreach (@data) { s/$;/;/g }
$self->{group} = [map {$self->toAce($_)} @data];
}
return wantarray ? @{$self->{group}} : $self->{group}->[0];
}
# bioperl compatibility
sub primary_tag { shift->type(@_) }
sub source_tag { shift->subtype(@_) }
sub db { # database identifier (from Ace::Sequence::Multi)
my $self = shift;
Ace/Sequence/Feature.pm view on Meta::CPAN
# 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
}
return $self->tag2ace($tag,@values);
}
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
$base->{offset} = $offset;
$base->{length} = $len;
bless $base,ref($segments[0]);
return bless {
base => $base,
segments => $segments,
},$class;
}
sub smapped { 1; }
sub asString {
shift->{base}->info;
}
sub type { return 'similarity'; }
sub relative {
my $self = shift;
my $d = $self->{relative};
$self->{relative} = shift if @_;
$d;
}
sub segments {
my $self = shift;
return $self->{segments} ? @{$self->{segments}} : () unless $self->relative;
# otherwise, we have to handle relative coordinates
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
Ace/Sequence/Gene.pm view on Meta::CPAN
my $d = $self->{relative};
$self->{relative} = shift if @_;
$d;
}
sub introns {
my $self = shift;
return $self->{intron} ? @{$self->{intron}} : () unless $self->relative;
# otherwise, we have to handle relative coordinates
my $base = $self->{base};
my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{intron}};
return $self->strand < 0 ? reverse @e : @e;
}
sub exons {
my $self = shift;
return $self->{exon} ? @{$self->{exon}} : () unless $self->relative;
# otherwise, we have to handle relative coordinates
my $base = $self->{base};
my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{exon}};
return $self->strand < 0 ? reverse @e : @e;
}
1;
__END__
=head1 NAME
Ace::Sequence::Gene - Simple "Gene" Object
Ace/Sequence/Multi.pm view on Meta::CPAN
# backward compatibility
*db_id = \&db;
sub new {
my $pack = shift;
my ($secondary,$rest) = rearrange([['SECONDARY','DBS']],@_);
return unless my $obj = $pack->SUPER::new($rest);
if (defined $secondary) {
my @s = ref $secondary eq 'ARRAY' ? @$secondary : $secondary;
$obj->{'secondary'} = { map { $_=> $_} @s };
}
return bless $obj,$pack;
}
sub secondary {
return unless my $s = $_[0]->{'secondary'};
return values %{$s};
}
Ace/Sequence/Multi.pm view on Meta::CPAN
return join("\n",@lines,'');
}
# turn a GFF file and a filter into a list of Ace::Sequence::Feature objects
sub _make_features {
my $self = shift;
my ($gff,$filter) = @_;
my @dbs = ($self->db,$self->secondary);
my %dbs = map { $_->asString => $_ } @dbs;
my ($r,$r_offset,$r_strand) = $self->refseq;
my $abs = $self->absolute;
if ($abs) {
$r_offset = 0;
$r = $self->parent;
$r_strand = '+1';
}
my @features;
foreach (split("\n",$gff)) {
Ace/Sequence/Multi.pm view on Meta::CPAN
=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
annotation databases share the same cosmid map.
=head1 OBJECT CREATION
You will use the new() method to create new Ace::Sequence::Multi
objects. The arguments are identical to the those in the
Ace::Sequence parent class, with the addition of an option
B<-secondary> argument, which points to one or more secondary databases
from which to fetch annotation information.
=over 4
Ace/Sequence/Transcript.pm view on Meta::CPAN
# my $introns = $args{intron};
# my $exons = $args{exon};
# my $sequence = $args{base}; # this is the Ace::Sequence::Feature object
# return bless {base => $sequence,
# intron => $introns,
# exon => $exons,
# cds => $cds,},$class;
}
sub smapped { 1; }
sub asString {
shift->{base}->info;
}
sub type {
return 'Transcript';
}
sub relative {
Ace/Sequence/Transcript.pm view on Meta::CPAN
my $d = $self->{relative};
$self->{relative} = shift if @_;
$d;
}
sub introns {
my $self = shift;
return $self->{intron} ? @{$self->{intron}} : () unless $self->relative;
# otherwise, we have to handle relative coordinates
my $base = $self->{base};
my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{intron}};
return $self->strand < 0 ? reverse @e : @e;
}
sub exons {
my $self = shift;
return $self->{exon} ? @{$self->{exon}} : () unless $self->relative;
# otherwise, we have to handle relative coordinates
my $base = $self->{base};
my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{exon}};
return $self->strand < 0 ? reverse @e : @e;
}
sub cds {
my $self = shift;
return $self->{cds} ? @{$self->{cds}} : () unless $self->relative;
# otherwise, we have to handle relative coordinates
my $base = $self->{base};
my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{cds}};
return $self->strand < 0 ? reverse @e : @e;
}
1;
__END__
=head1 NAME
Ace::Sequence::Transcript - Simple "Gene" Object
docs/ACE_SERVER_TRAPS.HOWTO
docs/ACE_SERVER_TRAPS.HOWTO.html
docs/GFF_Spec.html
docs/NEW_DB.HOWTO
docs/README
examples/README
examples/ace.pl
examples/authors.pl
examples/authors2.pl
examples/coauthors.pl
examples/draw_seqmap.pl
examples/dump_cdna.pl
examples/exons.pl
examples/exons.txt
examples/gif.pl
examples/sequence.pl
examples/upstream.pl
examples/upstream2.pl
install.PLS
make_docs.PLS
t/basic.t
t/object.t
t/sequence.t
t/update.t
typemap
util/install.PLS
util/ace.PLS
META.yml Module meta-data (added by MakeMaker)
README.ACEBROWSER view on Meta::CPAN
appear.
# configuration for the "basic" search script
@BASIC_OBJECTS =
('Any' => '<i>Anything</i>',
'Locus' => 'Confirmed Gene',
'Predicted_gene' => 'Predicted Gene',
'Sequence' => 'Sequence (any)',
'Genome_sequence', => 'Sequence (genomic)',
'Author' => 'Author',
'Genetic_map' => 'Genetic Map',
'Sequence_map' => 'Sequence Map',
'Strain' => 'Worm Strain',
'Clone' => 'Clone'
);
The @BASIC_OBJECTS array is used by the "basic" search script. It
indicates the Acedb classes to offer to the user to search on, and the
labels to use for each class. For example, the default configuration
will present the user with a radio button labeled "Confirmed Gene" for
use in searching the Acedb class "Locus".
acebrowser/cgi-bin/generic/model view on Meta::CPAN
$obj =~s/\\n/<BR>/g;
return ($obj,0);
}
# if we get here, we're dealing with an object or tag
my $name = $obj->name;
# modperl screws up with subroutine references for some reason
my $page_name = param('name');
my $page_class = param('class');
my %squash = map { $_ => 1; } grep($_ ne '',param('squash'));
my %expand = map { $_ => 1; } grep($_ ne '',param('expand'));
my ($n,$c) = (escape($name),escape($obj->class));
my ($pn,$pc) = (escape($page_name),escape($page_class));
my $cnt = $obj->col;
my $title = $name;
if ($cnt > 1) {
if ($squash{$name} || ($cnt > MAXEXPAND && !$expand{$name})) {
my $to_squash = join('&squash=',map { escape($_) } grep $name ne $_,keys %squash);
my $to_expand = join('&expand=',map { escape($_) } (keys %expand,$name));
return (a({-href=>url(-relative=>1,-path_info=>1)
. "?name=$pn&class=$pc"
. ($to_squash ? "&squash=$to_squash" : '')
. ($to_expand ? "&expand=$to_expand" : '')
. "#$name",
-name=>"$name",
-target=>"_self"},
b(font({-color=>CLOSEDCOLOR},"$title ($cnt)"))),
1);
} else {
my $to_squash = join('&squash=',map { escape($_) } (keys %squash,$name));
my $to_expand = join('&expand=',map { escape($_) } grep $name ne $_,keys %expand);
return (a({-href=>url(-relative=>1,-path_info=>1)
. "?name=$pn&class=$pc"
. ($to_squash ? "&squash=$to_squash" : '')
. ($to_expand ? "&expand=$to_expand" : '')
. "#$name",
-name=>"$name",
-target=>"_self"},
b(font({-color=>OPENCOLOR},"$title"))),
0);
}
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
#!/usr/bin/perl
# -*- Mode: perl -*-
# file: pic
# NOTE: This is a very confusing looking script. It is basically a client-side image map, but it
# uses a variety of workarounds so that when the user clicks in an area that isn't part of the map,
# the coordinates of the click are passed back to the script as a server-side image map. It uses
# javascript tricks to do this, but unfortunately the tricks are different for Netscape and Internet
# explorer.
use strict;
use Ace 1.51;
use File::Path;
use CGI 2.42 qw/:standard escape Map Area Layer *p *TR *td *table/;
use CGI::Carp;
use Ace::Browser::AceSubs qw(:DEFAULT Style Url);
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
print h1({-class=>'error'},'Sorry, but graphical displays have been disabled temporarily.');
return;
}
# 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
my $u = Url('pic') . "?" . query_string();
$u .= param('click') ? ',' : '&click=';
print
img({-src => $image_path,
-name => 'theMapImg',
-border=> 0,
# this is for Internet Explorer, has no effect on Netscape!
-onClick=>"send_click(event,'$u')",
-usemap=>'#theMap',
-isMap=>undef}),
;
print_map($name,$class,$boxes);
}
sub print_map {
my ($name,$class,$boxes) = @_;
my @lines;
my $old_clicks = param('click');
Delete('click');
# Collect some statistics in order to inhibit those features
# that are too dense to click on sensibly.
my %centers;
foreach my $box (@$boxes) {
my $center = center($box->{'coordinates'});
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
push(@lines,qq(<AREA shape="rect"
onMouseOver="return s(this,'$jcomment')"
coords="$coords"
href="$url">));
last CASE;
}
last CASE if $box->{class} eq 'System';
if ($box->{class} eq 'BUTTON') {
my ($c) = map { "$_->[0]-$_->[1]" } [ map { 2+$_ } @{$box->{coordinates}}[0..1]];
my $clicks = $old_clicks ? "$old_clicks,$c" : $c;
my $url = Url('pic',query_string() . "&click=$clicks");
push(@lines,qq(<AREA shape="rect"
coords="$coords"
onMouseOver="return s(this,'$jcomment')"
target="_self"
href="$url">));
last CASE;
}
my $n = escape($box->{'name'});
acebrowser/cgi-bin/generic/pic view on Meta::CPAN
# Create default handling. Bad use of javascript, but can't think of any other way.
my $url = Url('pic', query_string());
my $simple_url = $url;
$url .= "&click=$old_clicks";
$url .= "," if $old_clicks;
push(@lines,qq(<AREA shape="default"
alt=""
onClick="send_click(event,'$url'); return false"
onMouseOver="return s(this,'clickable region')"
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 {
my $db = shift;
my $chrom = shift;
acebrowser/cgi-bin/generic/tree view on Meta::CPAN
}
return ($obj,0);
}
# if we get here, we're dealing with an object or tag
my $name = $obj->name;
# modperl screws up with subroutine references for some reason
my $page_name = param('name');
my $page_class = param('class');
my %squash = map { $_ => 1; } grep($_ ne '',param('squash'));
my %expand = map { $_ => 1; } grep($_ ne '',param('expand'));
my ($n,$c) = (escape($name),escape($obj->class));
my ($pn,$pc) = (escape($page_name),escape($page_class));
my $cnt = $obj->col;
# here's a hack case for external images
if ($obj->isTag && $name eq 'Pick_me_to_call' && $obj->right(2)=~/\.(jpg|jpeg|gif)$/i) {
return (td({-colspan=>2},img({-src=>AceImageHackURL($obj->right(2))})),1,1);
}
my $title = $name;
if ($cnt > 1) {
if ($squash{$name} || ($cnt > MAXEXPAND && !$expand{$name})) {
my $to_squash = join('&squash=',map { escape($_) } grep $name ne $_,keys %squash);
my $to_expand = join('&expand=',map { escape($_) } (keys %expand,$name));
return (a({-href=>Url(url(-relative=>1),"name=$pn&class=$pc")
. ($to_squash ? "&squash=$to_squash" : '')
. ($to_expand ? "&expand=$to_expand" : '')
. "#$name",
-name=>"$name",
-target=>"_self"},
b(font({-color=>CLOSEDCOLOR},"$title ($cnt)"))),
1);
} else {
my $to_squash = join('&squash=',map { escape($_) } (keys %squash,$name));
my $to_expand = join('&expand=',map { escape($_) } grep $name ne $_,keys %expand);
return (a({-href=>Url(url(-relative=>1), "name=$pn&class=$pc")
. ($to_squash ? "&squash=$to_squash" : '')
. ($to_expand ? "&expand=$to_expand" : '')
. "#$name",
-name=>"$name",
-target=>"_self"},
b(font({-color=>OPENCOLOR},"$title"))),
0);
}
}
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
}
print
p({-class=>'small'},
"Use this form to send new data or corrections to",
"the maintainers of this database. An e-mail message",
"will be sent to the individuals selected from the list",
"below."),
blockquote({-class=>'small'},
checkbox_group(-name => 'recipients',
-Values => [(0..$#FEEDBACK_RECIPIENTS)],
-Labels => { map {
$_=>"$FEEDBACK_RECIPIENTS[$_]->[0] ($FEEDBACK_RECIPIENTS[$_]->[1])"
} (0..$#FEEDBACK_RECIPIENTS) },
-defaults=>\@defaults,
-linebreak=>1));
}
sub print_bottom {
print Footer;
}
acebrowser/cgi-bin/misc/feedback view on Meta::CPAN
submit(-name=>'return',-value=>'Cancel & Return',-class=>'error'),
submit(-name=>'submit',-value=>'Submit Data');
}
sub send_mail {
my ($obj_name,$obj_class,$where_from) = @_;
$obj_name ||= '(unknown name)';
$obj_class ||= '(unknown class)';
$where_from ||= '(unknown)';
my @addresses = map { $FEEDBACK_RECIPIENTS[$_] ?
$FEEDBACK_RECIPIENTS[$_]->[0]
: () } param('recipients');
my @missing;
push @missing,"At least one message recipient"
unless @addresses;
push @missing,"Your full name (needed for proper attribution)"
unless my $name = param('full_name');
push @missing,"Your institution (needed for proper attribution)"
unless my $institution = param('institution');
push @missing,"Your e-mail address"
acebrowser/cgi-bin/moviedb/movie view on Meta::CPAN
textfield(-name=>'name'),
hidden(class=>'Movie'),
),
end_form;
}
sub print_report {
my $movie = shift;
print h2($movie->Title);
print p("Directed by ",map { ObjectLink($_,$_->Full_name) } $movie->Director);
print table(
TR({-align=>'LEFT'},
th('Released'),
td($movie->Released)),
TR({-align=>'LEFT'},
th(em('Starring')),
td(map { ObjectLink($_,$_->Full_name) } $movie->Cast)),
TR({-align=>'LEFT'},
th(em('Writer(s)')),
td(map { ObjectLink($_,$_->Full_name) } $movie->Writer)),
$movie->Based_on ?
(TR({-align=>'LEFT'},
th(em('Adapted from')),
td(map { ObjectLink($_,$_->Title) } $movie->Based_on)))
: '',
);
}
acebrowser/cgi-bin/moviedb/person view on Meta::CPAN
if ($person->Born || $person->Height) {
print h3('Fun Facts'),
table({-border=>undef},
TR({-align=>'LEFT'}, th('Height'), td($person->Height(1) || '?')),
TR({-align=>'LEFT'}, th('Birthdate'),td($person->Born(1)|| '?'))
),
}
if (my @directed = $person->Directed) {
print h3('Movies Directed');
my @full_names = map { ObjectLink($_,$_->Title) } @directed;
print ol(li \@full_names);
}
if (my @scripted = $person->Scripted) {
print h3('Movies Scripted');
my @full_names = map { ObjectLink($_,$_->Title) } @scripted;
print ol(li \@full_names);
}
if (my @stars_in = $person->Stars_in) {
print h3('Starring Roles In');
my @full_names = map { ObjectLink($_,$_->Title) } @stars_in;
print ol(li \@full_names);
}
if (my @books = $person->Wrote) {
print h3('Wrote');
my @full_names = map { ObjectLink($_,$_->Title) } @books;
print ol(li \@full_names);
}
}
acebrowser/cgi-bin/searches/basic view on Meta::CPAN
use strict 'vars';
use vars qw/$DB $URL %EQUIV/;
use Ace 1.51;
use CGI 2.42 qw/:standard :html3 escape/;
use CGI::Carp qw/fatalsToBrowser/;
use Ace::Browser::AceSubs qw(:DEFAULT DoRedirect);
use Ace::Browser::SearchSubs;
my $classlist = Configuration()->Basic_objects;
my @classlist = @{$classlist}[map {2*$_} (0..@$classlist/2-1)]; # keep keys, preserving the order
my $JSCRIPT=<<END;
function focussearch() {
document.SimpleForm.query.focus();
document.SimpleForm.query.select();
return (false);
}
END
acebrowser/cgi-bin/searches/basic view on Meta::CPAN
my $label = $class eq 'Any' ? '' :$class;
if ($count > 0) {
print p(strong($count),"$label objects found");
} else {
print p(font{-color=>'red'},'No matching objects found.',
'Try searching again with a * wildcard before or after the name (already added for you).');
return;
}
my @objects;
if ($class eq 'Any') {
@objects = map { a({-href=>Object2URL($_)},$_->class . ": $_") }
sort { $a->class cmp $b->class } @$objs;
} else {
@objects = map { a({-href=>Object2URL($_)},"$_") } @$objs;
}
AceResultsTable(\@objects,$count,$offset);
}
sub do_grep {
my ($text,$offset) = @_;
my $count;
my (@objs) = $DB->grep(-pattern=> $text,
-count => MAXOBJECTS,
-offset => $offset,
( run in 2.385 seconds using v1.01-cache-2.11-cpan-140bd7fdf52 )