+++ /dev/null
-package Maasha::BBrowser::Draw;
-
-# Copyright (C) 2009 Martin A. Hansen.
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-
-# http://www.gnu.org/copyleft/gpl.html
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-# Routines for creating Biopieces Browser graphics using Cairo and Pango.
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-use warnings;
-use strict;
-use Data::Dumper;
-use Cairo;
-use Pango;
-use MIME::Base64;
-
-use vars qw( @ISA @EXPORT );
-
-@ISA = qw( Exporter );
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-sub draw_feature
-{
- # Martin A. Hansen, November 2009
-
- # Given a list of features add these to
- # a Cairo::Context object.
-
- my ( $cr, # Cairo::Context object
- $features, # List of features
- ) = @_;
-
- # Returns nothing.
-
- my ( $feature );
-
- foreach $feature ( @{ $features } )
- {
- $cr->set_source_rgb( @{ $feature->{ 'color' } } );
-
- if ( $feature->{ 'type' } eq 'line' )
- {
- $cr->set_line_width( $feature->{ 'line_width' } );
- $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
- $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
- }
- elsif ( $feature->{ 'type' } eq 'rect' )
- {
- $cr->rectangle(
- $feature->{ 'x1' },
- $feature->{ 'y1' },
- $feature->{ 'x2' } - $feature->{ 'x1' },
- $feature->{ 'y2' } - $feature->{ 'y1' },
- );
-
- $cr->fill;
- }
- elsif ( $feature->{ 'type' } eq 'text' )
- {
- $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
- $cr->set_font_size( $feature->{ 'font_size' } );
- $cr->show_text( $feature->{ 'txt' } );
- }
-
- $cr->stroke;
- }
-}
-
-
-sub palette
-{
- # Martin A. Hansen, November 2009.
-
- # Given a color number, pick that color from
- # the color palette and return.
-
- my ( $i, # color number
- ) = @_;
-
- # Returns a arrayref
-
- my ( $palette, $color );
-
- $palette = [
- [ 30, 130, 130 ],
- [ 30, 50, 150 ],
- [ 130, 130, 50 ],
- [ 130, 90, 130 ],
- [ 130, 70, 70 ],
- [ 70, 170, 130 ],
- [ 130, 170, 50 ],
- [ 30, 130, 130 ],
- [ 30, 50, 150 ],
- [ 130, 130, 50 ],
- [ 130, 90, 130 ],
- [ 130, 70, 70 ],
- [ 70, 170, 130 ],
- [ 130, 170, 50 ],
- ];
-
- $color = $palette->[ $i ];
-
- map { $_ /= 255 } @{ $color };
-
- return $color;
-}
-
-
-sub file_png
-{
- # Martin A. Hansen, October 2009.
-
- # Prints a Cairo::Surface object to a PNG file.
-
- my ( $surface, # Cairo::Surface object
- $file, # path to PNG file
- ) = @_;
-
- # Returns nothing
-
- $surface->write_to_png( $file );
-}
-
-
-sub base64_png
-{
- # Martin A. Hansen, December 2009.
-
- # Extract a PNG stream from a Cairo::Surface object
- # and convert it to base64 before returning it.
-
- my ( $surface, # Cairo::Surface object
- ) = @_;
-
- # Returns a string.
-
- my ( $png_data, $callback, $base64 );
-
- $png_data = "";
-
- $callback = sub { $png_data .= $_[ 1 ] };
-
- $surface->write_to_png_stream( $callback );
-
- $base64 = MIME::Base64::encode_base64( $png_data );
-
- return $base64;
-}
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-1;
-
-
+++ /dev/null
-package Maasha::BBrowser::Session;
-
-# Copyright (C) 2009 Martin A. Hansen.
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-
-# http://www.gnu.org/copyleft/gpl.html
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-# Routines for session handling of the Biopieces Browser.
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-use warnings;
-use strict;
-use Data::Dumper;
-use Digest::MD5;
-use Maasha::Common;
-use Maasha::Filesys;
-
-use vars qw( @ISA @EXPORT );
-
-@ISA = qw( Exporter );
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-sub session_new
-{
- # Martin A. Hansen, December 2009.
-
- # Create a new session id which is md5 hashed.
-
- # Returns a string.
-
- my ( $sid );
-
- $sid = Digest::MD5::md5_hex( Maasha::Common::get_sessionid() );
-
- return $sid;
-}
-
-
-sub session_restore
-{
- # Martin A. Hansen, December 2009.
-
- # Parses a tab seperated session file and returns the data
- # as a hash with user as key, and the rest of the columns as
- # a hash.
-
- my ( $file, # session file
- ) = @_;
-
- # Returns a hashref.
-
- my ( $fh, $line, $user, $password, $sid, $time, %session );
-
- $fh = Maasha::Filesys::file_read_open( $file );
-
- while ( $line = <$fh> )
- {
- chomp $line;
-
- ( $user, $password, $sid, $time ) = split /\t/, $line;
-
- $session{ $user } = {
- PASSWORD => $password,
- SESSION_ID => $sid,
- TIME => $time,
- };
- }
-
- close $fh;
-
- return wantarray ? %session : \%session;
-}
-
-
-sub session_store
-{
- # Martin A. Hansen, December 2009.
-
- # Stores a session hash to file.
-
- my ( $file, # file to store in.
- $session, # session to store.
- ) = @_;
-
- # Returns nothing.
-
- my ( $fh, $user );
-
- $fh = Maasha::Filesys::file_write_open( $file );
-
- foreach $user ( keys %{ $session } )
- {
- print $fh join(
- "\t",
- $user,
- $session->{ $user }->{ 'PASSWORD' },
- $session->{ $user }->{ 'SESSION_ID' },
- $session->{ $user }->{ 'TIME' }
- ), "\n";
- }
-
- close $fh;
-}
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-1;
+++ /dev/null
-package Maasha::BBrowser::Track;
-
-# Copyright (C) 2009 Martin A. Hansen.
-
-# This program is free software; you can redistribute it and/or
-# modify it under the terms of the GNU General Public License
-# as published by the Free Software Foundation; either version 2
-# of the License, or (at your option) any later version.
-
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
-
-# http://www.gnu.org/copyleft/gpl.html
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-# Routines for creating Biopieces Browser tracks.
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-use warnings;
-use strict;
-use Data::Dumper;
-use Maasha::Common;
-use Maasha::Calc;
-use Maasha::Filesys;
-use Maasha::KISS;
-use Maasha::Biopieces;
-use Maasha::Seq;
-
-use vars qw( @ISA @EXPORT );
-
-@ISA = qw( Exporter );
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-
-sub track_ruler
-{
- # Martin A. Hansen, November 2009.
-
- # Create a track with a ruler of tics and positions for
- # the browser window.
-
- my ( $cookie, # browser cookie
- ) = @_;
-
- # Returns a list.
-
- my ( $beg, $end, $factor, $step, $i, $txt, $x, @ruler );
-
- $beg = $cookie->{ 'NAV_START' };
- $end = $cookie->{ 'NAV_END' };
- $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg + 1 );
-
- $step = 10;
-
- while ( ( $end - $beg ) / $step > 20 ) {
- $step *= 5;
- }
-
- for ( $i = $beg; $i < $end; $i++ )
- {
- if ( ( $i % $step ) == 0 )
- {
- $txt = "|" . Maasha::Calc::commify( $i );
- $x = sprintf( "%.0f", ( ( $i - $beg ) * $factor ) + 2 );
-
- if ( $x > 0 and $x + ( $cookie->{ 'RULER_FONT_SIZE' } * length $txt ) < $cookie->{ 'IMG_WIDTH' } )
- {
- push @ruler, {
- type => 'text',
- txt => $txt,
- font_size => $cookie->{ 'RULER_FONT_SIZE' },
- color => $cookie->{ 'RULER_COLOR' },
- x1 => $x,
- y1 => $cookie->{ 'TRACK_OFFSET' },
- };
- }
- }
- }
-
- $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
-
- return wantarray ? @ruler : \@ruler;
-}
-
-
-sub track_seq
-{
- # Martin A. Hansen, November 2009.
-
- # Create a sequence track by extracting the appropriate
- # stretch of sequence from the sequence file.
-
- my ( $cookie, # browser cookie
- ) = @_;
-
- # Returns a list.
-
- my ( $file, $fh, $seq, @chars, $factor, $i, @seq_list );
-
- if ( $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 <= 220 )
- {
- $file = path_seq( $cookie );
- $fh = Maasha::Filesys::file_read_open( $file );
- $seq = Maasha::Filesys::file_read( $fh, $cookie->{ 'NAV_START' } - 1, $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 );
- close $fh;
-
- @chars = split //, $seq;
-
- $factor = $cookie->{ 'IMG_WIDTH' } / @chars;
-
- for ( $i = 0; $i < @chars; $i++ ) {
- push @seq_list, {
- type => 'text',
- txt => $chars[ $i ],
- font_size => $cookie->{ 'SEQ_FONT_SIZE' },
- color => $cookie->{ 'SEQ_COLOR' },
- x1 => sprintf( "%.0f", $i * $factor ),
- y1 => $cookie->{ 'TRACK_OFFSET' },
- };
- }
-
- $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
-
- return wantarray ? @seq_list : \@seq_list;
- }
- else
- {
- return;
- }
-}
-
-
-sub track_feature
-{
- # Martin A. Hansen, November 2009.
-
- # Create a track with features. If there are more than $cookie->FEAT_MAX
- # features the track created will be a histogram, else linear.
-
- my ( $track, # path to kiss file with track data
- $cookie, # cookie hash
- ) = @_;
-
- # Returns a list.
-
- my ( $index, $count, $track_name, $start, $end, $entries, $features );
-
- $start = $cookie->{ 'NAV_START' };
- $end = $cookie->{ 'NAV_END' };
-
- $index = Maasha::KISS::kiss_index_retrieve( "$track/track_data.kiss.index" );
- $count = Maasha::KISS::kiss_index_count( $index, $start, $end );
-
- $track_name = ( split "/", $track )[ -1 ];
- $track_name =~ s/^\d+_//;
- $track_name =~ s/_/ /g;
-
- $features = [ {
- type => 'text',
- txt => $track_name,
- font_size => $cookie->{ 'SEQ_FONT_SIZE' },
- color => $cookie->{ 'SEQ_COLOR' },
- x1 => 0,
- y1 => $cookie->{ 'TRACK_OFFSET' },
- } ];
-
- $cookie->{ 'TRACK_OFFSET' } += 10;
-
- if ( $count > $cookie->{ 'FEAT_MAX' } )
- {
- $entries = Maasha::KISS::kiss_index_get_blocks( $index, $start, $end );
- push @{ $features }, track_feature_histogram( $cookie, $start, $end, $entries );
- }
- else
- {
- $entries = Maasha::KISS::kiss_index_get_entries( "$track/track_data.kiss", $index, $start, $end );
- push @{ $features }, track_feature_linear( $cookie, $start, $end, $entries );
- }
-
- return wantarray ? @{ $features } : $features;
-}
-
-
-sub track_feature_linear
-{
- # Martin A. Hansen, November 2009.
-
- # Create a linear feature track where the granularity depends
- # on the lenght of the features and the browser window width.
-
- my ( $cookie, # hashref with image draw metrics
- $beg, # base window beg
- $end, # base window end
- $entries, # list of unsorted KISS entries
- ) = @_;
-
- # Returns a list.
-
- my ( $factor, $entry, $y_step, @ladder, $y_max, $w, $x1, $y1, $x2, $y2, @features );
-
- @{ $entries } = sort { $a->{ 'S_BEG' } <=> $b->{ 'S_BEG' } or $a->{ 'S_END' } <=> $b->{ 'S_END' } } @{ $entries };
-
- $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg + 1 );
- $y_step = 0;
- $y_max = 0;
-
- foreach $entry ( @{ $entries } )
- {
- $w = sprintf( "%.0f", ( $entry->{ 'S_END' } - $entry->{ 'S_BEG' } + 1 ) * $factor );
-
- if ( $w >= 1 )
- {
- $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } - $beg ) * $factor );
-
- for ( $y_step = 0; $y_step < @ladder; $y_step++ ) {
- last if $x1 >= $ladder[ $y_step ] + 1;
- }
-
- $y1 = $cookie->{ 'TRACK_OFFSET' } + ( ( 0.1 + $cookie->{ 'FEAT_WIDTH' } ) * $y_step );
-
- push @features, {
- type => 'rect',
- line_width => $cookie->{ 'FEAT_WIDTH' },
- color => $cookie->{ 'FEAT_COLOR' },
- title => "Q_ID: $entry->{ 'Q_ID' } S_BEG: $entry->{ 'S_BEG' } S_END: $entry->{ 'S_END' } STRAND: $entry->{ 'STRAND' }",
- q_id => $entry->{ 'Q_ID' },
- s_beg => $entry->{ 'S_BEG' },
- s_end => $entry->{ 'S_END' },
- strand => $entry->{ 'STRAND' },
- x1 => $x1,
- y1 => $y1,
- x2 => $x1 + $w,
- y2 => $y1 + $cookie->{ 'FEAT_WIDTH' },
- };
-
- $y_max = Maasha::Calc::max( $y_max, $y_step * ( 0.1 + $cookie->{ 'FEAT_WIDTH' } ) );
-
- push @features, feature_align( $entry, $beg, $y1, $factor, $cookie->{ 'FEAT_WIDTH' } ) if $entry->{ 'ALIGN' } ne '.';
-
- $ladder[ $y_step ] = $x1 + $w;
- }
- }
-
- $cookie->{ 'TRACK_OFFSET' } += $y_max + $cookie->{ 'TRACK_SPACE' };
-
- return wantarray ? @features : \@features;
-}
-
-
-sub feature_align
-{
- # Martin A. Hansen, November 2009.
-
- # Add to feature track alignment info if the granularity is
- # sufficient.
- # TODO: The printing of chars is imprecise.
-
- my ( $entry, # Partial KISS entry
- $beg, # base window beg
- $y_offset, # y axis draw offset
- $factor, # scale factor
- $feat_height, # hight of feature in pixels
- ) = @_;
-
- # Returns a list.
-
- my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
-
- $w = sprintf( "%.0f", 1 * $factor );
-
- if ( $w >= 1 )
- {
- foreach $align ( split /,/, $entry->{ 'ALIGN' } )
- {
- if ( $align =~ /(\d+):([ATCGN-])>([ATCGN-])/ )
- {
- $pos = $1;
- $nt_before = $2;
- $nt_after = $3;
- }
- else
- {
- Maasha::Common::error( qq(BAD align descriptor: "$align") );
- }
-
- $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } + $pos - $beg ) * $factor );
-
- push @features, {
- type => 'rect',
- line_width => $feat_height,
- color => [ 1, 0, 0 ],
- title => $align,
- x1 => $x1,
- y1 => $y_offset,
- x2 => $x1 + $w,
- y2 => $y_offset + $feat_height,
- };
-
- if ( $w > $feat_height )
- {
- push @features, {
- type => 'text',
- font_size => $feat_height + 2,
- color => [ 0, 0, 0 ],
- txt => $nt_after,
- x1 => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
- y1 => $y_offset + $feat_height,
- };
- }
- }
- }
-
- return wantarray ? @features : \@features;
-}
-
-
-sub track_feature_histogram
-{
- # Martin A. Hansen, November 2009.
-
- # Create a feature track as a histogram using information
- # from the index only thus avoiding to load features from the
- # file.
-
- my ( $cookie, # hashref with image draw metrics
- $min, # minimum base position
- $max, # maximum base position
- $blocks, # list of blocks
- ) = @_;
-
- # Returns a list.
-
- my ( $hist_height, $bucket_width, $bucket_count, $min_bucket, $factor, $factor_heigth, $max_height, $block, $bucket_beg, $bucket_end, $i, @buckets, $h, $x, @hist );
-
- return if $max <= $min;
-
- $hist_height = 100; # pixels
- $bucket_width = 5;
- $bucket_count = $cookie->{ 'IMG_WIDTH' } / $bucket_width;
- $factor = ( $cookie->{ 'IMG_WIDTH' } / $bucket_width ) / ( $max - $min + 1 );
-
- $min_bucket = 999999999;
- $max_height = 0;
-
- foreach $block ( @{ $blocks } )
- {
- $bucket_beg = int( $block->{ 'BEG' } * $factor );
- $bucket_end = int( $block->{ 'END' } * $factor );
-
- $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
-
- for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
- {
- $buckets[ $i ] += $block->{ 'COUNT' };
-
- $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
- }
- }
-
- if ( $max_height > 0 )
- {
- $factor_heigth = $hist_height / $max_height;
-
- $x = 0;
-
- for ( $i = $min_bucket; $i < @buckets; $i++ )
- {
- if ( defined $buckets[ $i ] )
- {
- $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
-
- if ( $h >= 1 )
- {
- push @hist, {
- type => 'line',
- line_width => $bucket_width,
- color => $cookie->{ 'FEAT_COLOR' },
- title => "Features: $buckets[ $i ]",
- x1 => $x,
- y1 => $cookie->{ 'TRACK_OFFSET' } + $hist_height,
- x2 => $x,
- y2 => $cookie->{ 'TRACK_OFFSET' } + $hist_height - $h,
- };
- }
- }
-
- $x += $bucket_width;
- }
- }
-
- $cookie->{ 'TRACK_OFFSET' } += $hist_height + $cookie->{ 'TRACK_SPACE' };
-
- return wantarray ? @hist : \@hist;
-}
-
-
-sub dna_get
-{
- # Martin A. Hansen, November 2009.
-
- # Returns the sequence from the contig in the beg/end interval
- # contained in the cookie.
-
- my ( $cookie, # cookie hash
- ) = @_;
-
- # Returns a string.
-
- my ( $path, $fh, $beg, $end, $len, $dna );
-
- $path = path_seq( $cookie );
-
- $beg = $cookie->{ 'S_BEG' };
- $end = $cookie->{ 'S_END' };
- $beg =~ tr/,//d;
- $end =~ tr/,//d;
- $len = $end - $beg + 1;
-
-
- $fh = Maasha::Filesys::file_read_open( $path );
-
- $dna = Maasha::Filesys::file_read( $fh, $beg, $len );
-
- $dna = Maasha::Seq::dna_revcomp( $dna ) if $cookie->{ 'STRAND' } eq '-';
-
- Maasha::Seq::wrap( \$dna, 100 );
-
- close $fh;
-
- return $dna;
-}
-
-
-sub path_seq
-{
- # Martin A. Hansen, November 2009.
-
- # Returns the path to the sequence file for a specified
- # contig as written in the cookie.
-
- my ( $cookie, # cookie hash
- ) = @_;
-
- # Returns a string.
-
- my ( $path );
-
- die qq(ERROR: no USER in cookie.\n) if not $cookie->{ 'USER' };
- die qq(ERROR: no CLADE in cookie.\n) if not $cookie->{ 'CLADE' };
- die qq(ERROR: no GENOME in cookie.\n) if not $cookie->{ 'GENOME' };
- die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
- die qq(ERROR: no CONTIG in cookie.\n) if not $cookie->{ 'CONTIG' };
-
- $path = join( "/",
- $cookie->{ 'DATA_DIR' },
- "Users",
- $cookie->{ 'USER' },
- $cookie->{ 'CLADE' },
- $cookie->{ 'GENOME' },
- $cookie->{ 'ASSEMBLY' },
- $cookie->{ 'CONTIG' },
- "Sequence",
- "sequence.txt"
- );
-
- die qq(ERROR: no such file: "$path".\n) if not -e $path;
-
- return $path;
-}
-
-
-sub path_tracks
-{
- # Martin A. Hansen, November 2009.
-
- # Returns a list of paths to all tracks for a specified
- # contig as written in the cookie.
-
- my ( $cookie, # cookie path
- ) = @_;
-
- # Returns a list.
-
- my ( $path, @tracks );
-
- die qq(ERROR: no USER in cookie.\n) if not $cookie->{ 'USER' };
- die qq(ERROR: no CLADE in cookie.\n) if not $cookie->{ 'CLADE' };
- die qq(ERROR: no GENOME in cookie.\n) if not $cookie->{ 'GENOME' };
- die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
- die qq(ERROR: no CONTIG in cookie.\n) if not $cookie->{ 'CONTIG' };
-
- $path = join( "/",
- $cookie->{ 'DATA_DIR' },
- "Users",
- $cookie->{ 'USER' },
- $cookie->{ 'CLADE' },
- $cookie->{ 'GENOME' },
- $cookie->{ 'ASSEMBLY' },
- $cookie->{ 'CONTIG' },
- "Tracks",
- );
-
- if ( -d $path )
- {
- @tracks = Maasha::Filesys::ls_dirs( $path );
-
- @tracks = grep { $_ !~ /\/\.\.?$/ } @tracks;
-
- return wantarray ? @tracks : \@tracks;
- }
- else
- {
- return wantarray ? () : [];
- }
-}
-
-
-sub search_tracks
-{
- # Martin A. Hansen, December 2009.
-
- # Uses grep to search all tracks in all contigs
- # for a given pattern and return a list of KISS entries.
-
- my ( $cookie, # cookie hash
- ) = @_;
-
- # Returns a list.
-
- my ( $contig, @tracks, $track, $file, $line, $out_file, $fh, $entry, @entries );
-
- foreach $contig ( @{ $cookie->{ 'LIST_CONTIG' } } )
- {
- $cookie->{ 'CONTIG' } = $contig;
-
- push @tracks, path_tracks( $cookie );
- }
-
- foreach $track ( @tracks )
- {
- $file = "$track/track_data.kiss";
-
- if ( -f $file )
- {
- $fh = Maasha::Filesys::file_read_open( $file );
-
- while ( $line = <$fh> )
- {
- chomp $line;
-
- if ( $line =~ /$cookie->{ 'SEARCH' }/i )
- {
- $entry = Maasha::KISS::kiss_entry_parse( $line );
-
- push @entries, $entry;
- }
- }
-
- close $fh;
- }
- }
-
- return wantarray ? @entries : \@entries;
-}
-
-
-# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-
-1;
-
--- /dev/null
+package Maasha::BBrowser::Draw;
+
+# Copyright (C) 2009 Martin A. Hansen.
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+# http://www.gnu.org/copyleft/gpl.html
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+# Routines for creating Biopieces Browser graphics using Cairo and Pango.
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+use warnings;
+use strict;
+use Data::Dumper;
+use Cairo;
+use Pango;
+use MIME::Base64;
+
+use vars qw( @ISA @EXPORT );
+
+@ISA = qw( Exporter );
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+sub draw_feature
+{
+ # Martin A. Hansen, November 2009
+
+ # Given a list of features add these to
+ # a Cairo::Context object.
+
+ my ( $cr, # Cairo::Context object
+ $features, # List of features
+ ) = @_;
+
+ # Returns nothing.
+
+ my ( $feature );
+
+ foreach $feature ( @{ $features } )
+ {
+ $cr->set_source_rgb( @{ $feature->{ 'color' } } );
+
+ if ( $feature->{ 'type' } eq 'line' )
+ {
+ $cr->set_line_width( $feature->{ 'line_width' } );
+ $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
+ $cr->line_to( $feature->{ 'x2' }, $feature->{ 'y2' } );
+ }
+ elsif ( $feature->{ 'type' } eq 'rect' )
+ {
+ $cr->rectangle(
+ $feature->{ 'x1' },
+ $feature->{ 'y1' },
+ $feature->{ 'x2' } - $feature->{ 'x1' },
+ $feature->{ 'y2' } - $feature->{ 'y1' },
+ );
+
+ $cr->fill;
+ }
+ elsif ( $feature->{ 'type' } eq 'text' )
+ {
+ $cr->move_to( $feature->{ 'x1' }, $feature->{ 'y1' } );
+ $cr->set_font_size( $feature->{ 'font_size' } );
+ $cr->show_text( $feature->{ 'txt' } );
+ }
+
+ $cr->stroke;
+ }
+}
+
+
+sub palette
+{
+ # Martin A. Hansen, November 2009.
+
+ # Given a color number, pick that color from
+ # the color palette and return.
+
+ my ( $i, # color number
+ ) = @_;
+
+ # Returns a arrayref
+
+ my ( $palette, $color );
+
+ $palette = [
+ [ 30, 130, 130 ],
+ [ 30, 50, 150 ],
+ [ 130, 130, 50 ],
+ [ 130, 90, 130 ],
+ [ 130, 70, 70 ],
+ [ 70, 170, 130 ],
+ [ 130, 170, 50 ],
+ [ 30, 130, 130 ],
+ [ 30, 50, 150 ],
+ [ 130, 130, 50 ],
+ [ 130, 90, 130 ],
+ [ 130, 70, 70 ],
+ [ 70, 170, 130 ],
+ [ 130, 170, 50 ],
+ ];
+
+ $color = $palette->[ $i ];
+
+ map { $_ /= 255 } @{ $color };
+
+ return $color;
+}
+
+
+sub file_png
+{
+ # Martin A. Hansen, October 2009.
+
+ # Prints a Cairo::Surface object to a PNG file.
+
+ my ( $surface, # Cairo::Surface object
+ $file, # path to PNG file
+ ) = @_;
+
+ # Returns nothing
+
+ $surface->write_to_png( $file );
+}
+
+
+sub base64_png
+{
+ # Martin A. Hansen, December 2009.
+
+ # Extract a PNG stream from a Cairo::Surface object
+ # and convert it to base64 before returning it.
+
+ my ( $surface, # Cairo::Surface object
+ ) = @_;
+
+ # Returns a string.
+
+ my ( $png_data, $callback, $base64 );
+
+ $png_data = "";
+
+ $callback = sub { $png_data .= $_[ 1 ] };
+
+ $surface->write_to_png_stream( $callback );
+
+ $base64 = MIME::Base64::encode_base64( $png_data );
+
+ return $base64;
+}
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+1;
+
+
--- /dev/null
+package Maasha::BBrowser::Session;
+
+# Copyright (C) 2009 Martin A. Hansen.
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+# http://www.gnu.org/copyleft/gpl.html
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+# Routines for session handling of the Biopieces Browser.
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+use warnings;
+use strict;
+use Data::Dumper;
+use Digest::MD5;
+use Maasha::Common;
+use Maasha::Filesys;
+
+use vars qw( @ISA @EXPORT );
+
+@ISA = qw( Exporter );
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+sub session_new
+{
+ # Martin A. Hansen, December 2009.
+
+ # Create a new session id which is md5 hashed.
+
+ # Returns a string.
+
+ my ( $sid );
+
+ $sid = Digest::MD5::md5_hex( Maasha::Common::get_sessionid() );
+
+ return $sid;
+}
+
+
+sub session_restore
+{
+ # Martin A. Hansen, December 2009.
+
+ # Parses a tab seperated session file and returns the data
+ # as a hash with user as key, and the rest of the columns as
+ # a hash.
+
+ my ( $file, # session file
+ ) = @_;
+
+ # Returns a hashref.
+
+ my ( $fh, $line, $user, $password, $sid, $time, %session );
+
+ $fh = Maasha::Filesys::file_read_open( $file );
+
+ while ( $line = <$fh> )
+ {
+ chomp $line;
+
+ ( $user, $password, $sid, $time ) = split /\t/, $line;
+
+ $session{ $user } = {
+ PASSWORD => $password,
+ SESSION_ID => $sid,
+ TIME => $time,
+ };
+ }
+
+ close $fh;
+
+ return wantarray ? %session : \%session;
+}
+
+
+sub session_store
+{
+ # Martin A. Hansen, December 2009.
+
+ # Stores a session hash to file.
+
+ my ( $file, # file to store in.
+ $session, # session to store.
+ ) = @_;
+
+ # Returns nothing.
+
+ my ( $fh, $user );
+
+ $fh = Maasha::Filesys::file_write_open( $file );
+
+ foreach $user ( keys %{ $session } )
+ {
+ print $fh join(
+ "\t",
+ $user,
+ $session->{ $user }->{ 'PASSWORD' },
+ $session->{ $user }->{ 'SESSION_ID' },
+ $session->{ $user }->{ 'TIME' }
+ ), "\n";
+ }
+
+ close $fh;
+}
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+1;
--- /dev/null
+package Maasha::BBrowser::Track;
+
+# Copyright (C) 2009 Martin A. Hansen.
+
+# This program is free software; you can redistribute it and/or
+# modify it under the terms of the GNU General Public License
+# as published by the Free Software Foundation; either version 2
+# of the License, or (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
+# http://www.gnu.org/copyleft/gpl.html
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+# Routines for creating Biopieces Browser tracks.
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+use warnings;
+use strict;
+use Data::Dumper;
+use Maasha::Common;
+use Maasha::Calc;
+use Maasha::Filesys;
+use Maasha::KISS;
+use Maasha::Biopieces;
+use Maasha::Seq;
+
+use vars qw( @ISA @EXPORT );
+
+@ISA = qw( Exporter );
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+
+sub track_ruler
+{
+ # Martin A. Hansen, November 2009.
+
+ # Create a track with a ruler of tics and positions for
+ # the browser window.
+
+ my ( $cookie, # browser cookie
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $beg, $end, $factor, $step, $i, $txt, $x, @ruler );
+
+ $beg = $cookie->{ 'NAV_START' };
+ $end = $cookie->{ 'NAV_END' };
+ $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg + 1 );
+
+ $step = 10;
+
+ while ( ( $end - $beg ) / $step > 20 ) {
+ $step *= 5;
+ }
+
+ for ( $i = $beg; $i < $end; $i++ )
+ {
+ if ( ( $i % $step ) == 0 )
+ {
+ $txt = "|" . Maasha::Calc::commify( $i );
+ $x = sprintf( "%.0f", ( ( $i - $beg ) * $factor ) + 2 );
+
+ if ( $x > 0 and $x + ( $cookie->{ 'RULER_FONT_SIZE' } * length $txt ) < $cookie->{ 'IMG_WIDTH' } )
+ {
+ push @ruler, {
+ type => 'text',
+ txt => $txt,
+ font_size => $cookie->{ 'RULER_FONT_SIZE' },
+ color => $cookie->{ 'RULER_COLOR' },
+ x1 => $x,
+ y1 => $cookie->{ 'TRACK_OFFSET' },
+ };
+ }
+ }
+ }
+
+ $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
+
+ return wantarray ? @ruler : \@ruler;
+}
+
+
+sub track_seq
+{
+ # Martin A. Hansen, November 2009.
+
+ # Create a sequence track by extracting the appropriate
+ # stretch of sequence from the sequence file.
+
+ my ( $cookie, # browser cookie
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $file, $fh, $seq, @chars, $factor, $i, @seq_list );
+
+ if ( $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 <= 220 )
+ {
+ $file = path_seq( $cookie );
+ $fh = Maasha::Filesys::file_read_open( $file );
+ $seq = Maasha::Filesys::file_read( $fh, $cookie->{ 'NAV_START' } - 1, $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 );
+ close $fh;
+
+ @chars = split //, $seq;
+
+ $factor = $cookie->{ 'IMG_WIDTH' } / @chars;
+
+ for ( $i = 0; $i < @chars; $i++ ) {
+ push @seq_list, {
+ type => 'text',
+ txt => $chars[ $i ],
+ font_size => $cookie->{ 'SEQ_FONT_SIZE' },
+ color => $cookie->{ 'SEQ_COLOR' },
+ x1 => sprintf( "%.0f", $i * $factor ),
+ y1 => $cookie->{ 'TRACK_OFFSET' },
+ };
+ }
+
+ $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
+
+ return wantarray ? @seq_list : \@seq_list;
+ }
+ else
+ {
+ return;
+ }
+}
+
+
+sub track_feature
+{
+ # Martin A. Hansen, November 2009.
+
+ # Create a track with features. If there are more than $cookie->FEAT_MAX
+ # features the track created will be a histogram, else linear.
+
+ my ( $track, # path to kiss file with track data
+ $cookie, # cookie hash
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $index, $count, $track_name, $start, $end, $entries, $features );
+
+ $start = $cookie->{ 'NAV_START' };
+ $end = $cookie->{ 'NAV_END' };
+
+ $index = Maasha::KISS::kiss_index_retrieve( "$track/track_data.kiss.index" );
+ $count = Maasha::KISS::kiss_index_count( $index, $start, $end );
+
+ $track_name = ( split "/", $track )[ -1 ];
+ $track_name =~ s/^\d+_//;
+ $track_name =~ s/_/ /g;
+
+ $features = [ {
+ type => 'text',
+ txt => $track_name,
+ font_size => $cookie->{ 'SEQ_FONT_SIZE' },
+ color => $cookie->{ 'SEQ_COLOR' },
+ x1 => 0,
+ y1 => $cookie->{ 'TRACK_OFFSET' },
+ } ];
+
+ $cookie->{ 'TRACK_OFFSET' } += 10;
+
+ if ( $count > $cookie->{ 'FEAT_MAX' } )
+ {
+ $entries = Maasha::KISS::kiss_index_get_blocks( $index, $start, $end );
+ push @{ $features }, track_feature_histogram( $cookie, $start, $end, $entries );
+ }
+ else
+ {
+ $entries = Maasha::KISS::kiss_index_get_entries( "$track/track_data.kiss", $index, $start, $end );
+ push @{ $features }, track_feature_linear( $cookie, $start, $end, $entries );
+ }
+
+ return wantarray ? @{ $features } : $features;
+}
+
+
+sub track_feature_linear
+{
+ # Martin A. Hansen, November 2009.
+
+ # Create a linear feature track where the granularity depends
+ # on the lenght of the features and the browser window width.
+
+ my ( $cookie, # hashref with image draw metrics
+ $beg, # base window beg
+ $end, # base window end
+ $entries, # list of unsorted KISS entries
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $factor, $entry, $y_step, @ladder, $y_max, $w, $x1, $y1, $x2, $y2, @features );
+
+ @{ $entries } = sort { $a->{ 'S_BEG' } <=> $b->{ 'S_BEG' } or $a->{ 'S_END' } <=> $b->{ 'S_END' } } @{ $entries };
+
+ $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg + 1 );
+ $y_step = 0;
+ $y_max = 0;
+
+ foreach $entry ( @{ $entries } )
+ {
+ $w = sprintf( "%.0f", ( $entry->{ 'S_END' } - $entry->{ 'S_BEG' } + 1 ) * $factor );
+
+ if ( $w >= 1 )
+ {
+ $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } - $beg ) * $factor );
+
+ for ( $y_step = 0; $y_step < @ladder; $y_step++ ) {
+ last if $x1 >= $ladder[ $y_step ] + 1;
+ }
+
+ $y1 = $cookie->{ 'TRACK_OFFSET' } + ( ( 0.1 + $cookie->{ 'FEAT_WIDTH' } ) * $y_step );
+
+ push @features, {
+ type => 'rect',
+ line_width => $cookie->{ 'FEAT_WIDTH' },
+ color => $cookie->{ 'FEAT_COLOR' },
+ title => "Q_ID: $entry->{ 'Q_ID' } S_BEG: $entry->{ 'S_BEG' } S_END: $entry->{ 'S_END' } STRAND: $entry->{ 'STRAND' }",
+ q_id => $entry->{ 'Q_ID' },
+ s_beg => $entry->{ 'S_BEG' },
+ s_end => $entry->{ 'S_END' },
+ strand => $entry->{ 'STRAND' },
+ x1 => $x1,
+ y1 => $y1,
+ x2 => $x1 + $w,
+ y2 => $y1 + $cookie->{ 'FEAT_WIDTH' },
+ };
+
+ $y_max = Maasha::Calc::max( $y_max, $y_step * ( 0.1 + $cookie->{ 'FEAT_WIDTH' } ) );
+
+ push @features, feature_align( $entry, $beg, $y1, $factor, $cookie->{ 'FEAT_WIDTH' } ) if $entry->{ 'ALIGN' } ne '.';
+
+ $ladder[ $y_step ] = $x1 + $w;
+ }
+ }
+
+ $cookie->{ 'TRACK_OFFSET' } += $y_max + $cookie->{ 'TRACK_SPACE' };
+
+ return wantarray ? @features : \@features;
+}
+
+
+sub feature_align
+{
+ # Martin A. Hansen, November 2009.
+
+ # Add to feature track alignment info if the granularity is
+ # sufficient.
+ # TODO: The printing of chars is imprecise.
+
+ my ( $entry, # Partial KISS entry
+ $beg, # base window beg
+ $y_offset, # y axis draw offset
+ $factor, # scale factor
+ $feat_height, # hight of feature in pixels
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
+
+ $w = sprintf( "%.0f", 1 * $factor );
+
+ if ( $w >= 1 )
+ {
+ foreach $align ( split /,/, $entry->{ 'ALIGN' } )
+ {
+ if ( $align =~ /(\d+):([ATCGN-])>([ATCGN-])/ )
+ {
+ $pos = $1;
+ $nt_before = $2;
+ $nt_after = $3;
+ }
+ else
+ {
+ Maasha::Common::error( qq(BAD align descriptor: "$align") );
+ }
+
+ $x1 = sprintf( "%.0f", ( $entry->{ 'S_BEG' } + $pos - $beg ) * $factor );
+
+ push @features, {
+ type => 'rect',
+ line_width => $feat_height,
+ color => [ 1, 0, 0 ],
+ title => $align,
+ x1 => $x1,
+ y1 => $y_offset,
+ x2 => $x1 + $w,
+ y2 => $y_offset + $feat_height,
+ };
+
+ if ( $w > $feat_height )
+ {
+ push @features, {
+ type => 'text',
+ font_size => $feat_height + 2,
+ color => [ 0, 0, 0 ],
+ txt => $nt_after,
+ x1 => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
+ y1 => $y_offset + $feat_height,
+ };
+ }
+ }
+ }
+
+ return wantarray ? @features : \@features;
+}
+
+
+sub track_feature_histogram
+{
+ # Martin A. Hansen, November 2009.
+
+ # Create a feature track as a histogram using information
+ # from the index only thus avoiding to load features from the
+ # file.
+
+ my ( $cookie, # hashref with image draw metrics
+ $min, # minimum base position
+ $max, # maximum base position
+ $blocks, # list of blocks
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $hist_height, $bucket_width, $bucket_count, $min_bucket, $factor, $factor_heigth, $max_height, $block, $bucket_beg, $bucket_end, $i, @buckets, $h, $x, @hist );
+
+ return if $max <= $min;
+
+ $hist_height = 100; # pixels
+ $bucket_width = 5;
+ $bucket_count = $cookie->{ 'IMG_WIDTH' } / $bucket_width;
+ $factor = ( $cookie->{ 'IMG_WIDTH' } / $bucket_width ) / ( $max - $min + 1 );
+
+ $min_bucket = 999999999;
+ $max_height = 0;
+
+ foreach $block ( @{ $blocks } )
+ {
+ $bucket_beg = int( $block->{ 'BEG' } * $factor );
+ $bucket_end = int( $block->{ 'END' } * $factor );
+
+ $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
+
+ for ( $i = $bucket_beg; $i <= $bucket_end; $i++ )
+ {
+ $buckets[ $i ] += $block->{ 'COUNT' };
+
+ $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
+ }
+ }
+
+ if ( $max_height > 0 )
+ {
+ $factor_heigth = $hist_height / $max_height;
+
+ $x = 0;
+
+ for ( $i = $min_bucket; $i < @buckets; $i++ )
+ {
+ if ( defined $buckets[ $i ] )
+ {
+ $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
+
+ if ( $h >= 1 )
+ {
+ push @hist, {
+ type => 'line',
+ line_width => $bucket_width,
+ color => $cookie->{ 'FEAT_COLOR' },
+ title => "Features: $buckets[ $i ]",
+ x1 => $x,
+ y1 => $cookie->{ 'TRACK_OFFSET' } + $hist_height,
+ x2 => $x,
+ y2 => $cookie->{ 'TRACK_OFFSET' } + $hist_height - $h,
+ };
+ }
+ }
+
+ $x += $bucket_width;
+ }
+ }
+
+ $cookie->{ 'TRACK_OFFSET' } += $hist_height + $cookie->{ 'TRACK_SPACE' };
+
+ return wantarray ? @hist : \@hist;
+}
+
+
+sub dna_get
+{
+ # Martin A. Hansen, November 2009.
+
+ # Returns the sequence from the contig in the beg/end interval
+ # contained in the cookie.
+
+ my ( $cookie, # cookie hash
+ ) = @_;
+
+ # Returns a string.
+
+ my ( $path, $fh, $beg, $end, $len, $dna );
+
+ $path = path_seq( $cookie );
+
+ $beg = $cookie->{ 'S_BEG' };
+ $end = $cookie->{ 'S_END' };
+ $beg =~ tr/,//d;
+ $end =~ tr/,//d;
+ $len = $end - $beg + 1;
+
+
+ $fh = Maasha::Filesys::file_read_open( $path );
+
+ $dna = Maasha::Filesys::file_read( $fh, $beg, $len );
+
+ $dna = Maasha::Seq::dna_revcomp( $dna ) if $cookie->{ 'STRAND' } eq '-';
+
+ Maasha::Seq::wrap( \$dna, 100 );
+
+ close $fh;
+
+ return $dna;
+}
+
+
+sub path_seq
+{
+ # Martin A. Hansen, November 2009.
+
+ # Returns the path to the sequence file for a specified
+ # contig as written in the cookie.
+
+ my ( $cookie, # cookie hash
+ ) = @_;
+
+ # Returns a string.
+
+ my ( $path );
+
+ die qq(ERROR: no USER in cookie.\n) if not $cookie->{ 'USER' };
+ die qq(ERROR: no CLADE in cookie.\n) if not $cookie->{ 'CLADE' };
+ die qq(ERROR: no GENOME in cookie.\n) if not $cookie->{ 'GENOME' };
+ die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
+ die qq(ERROR: no CONTIG in cookie.\n) if not $cookie->{ 'CONTIG' };
+
+ $path = join( "/",
+ $cookie->{ 'DATA_DIR' },
+ "Users",
+ $cookie->{ 'USER' },
+ $cookie->{ 'CLADE' },
+ $cookie->{ 'GENOME' },
+ $cookie->{ 'ASSEMBLY' },
+ $cookie->{ 'CONTIG' },
+ "Sequence",
+ "sequence.txt"
+ );
+
+ die qq(ERROR: no such file: "$path".\n) if not -e $path;
+
+ return $path;
+}
+
+
+sub path_tracks
+{
+ # Martin A. Hansen, November 2009.
+
+ # Returns a list of paths to all tracks for a specified
+ # contig as written in the cookie.
+
+ my ( $cookie, # cookie path
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $path, @tracks );
+
+ die qq(ERROR: no USER in cookie.\n) if not $cookie->{ 'USER' };
+ die qq(ERROR: no CLADE in cookie.\n) if not $cookie->{ 'CLADE' };
+ die qq(ERROR: no GENOME in cookie.\n) if not $cookie->{ 'GENOME' };
+ die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
+ die qq(ERROR: no CONTIG in cookie.\n) if not $cookie->{ 'CONTIG' };
+
+ $path = join( "/",
+ $cookie->{ 'DATA_DIR' },
+ "Users",
+ $cookie->{ 'USER' },
+ $cookie->{ 'CLADE' },
+ $cookie->{ 'GENOME' },
+ $cookie->{ 'ASSEMBLY' },
+ $cookie->{ 'CONTIG' },
+ "Tracks",
+ );
+
+ if ( -d $path )
+ {
+ @tracks = Maasha::Filesys::ls_dirs( $path );
+
+ @tracks = grep { $_ !~ /\/\.\.?$/ } @tracks;
+
+ return wantarray ? @tracks : \@tracks;
+ }
+ else
+ {
+ return wantarray ? () : [];
+ }
+}
+
+
+sub search_tracks
+{
+ # Martin A. Hansen, December 2009.
+
+ # Uses grep to search all tracks in all contigs
+ # for a given pattern and return a list of KISS entries.
+
+ my ( $cookie, # cookie hash
+ ) = @_;
+
+ # Returns a list.
+
+ my ( $contig, @tracks, $track, $file, $line, $out_file, $fh, $entry, @entries );
+
+ foreach $contig ( @{ $cookie->{ 'LIST_CONTIG' } } )
+ {
+ $cookie->{ 'CONTIG' } = $contig;
+
+ push @tracks, path_tracks( $cookie );
+ }
+
+ foreach $track ( @tracks )
+ {
+ $file = "$track/track_data.kiss";
+
+ if ( -f $file )
+ {
+ $fh = Maasha::Filesys::file_read_open( $file );
+
+ while ( $line = <$fh> )
+ {
+ chomp $line;
+
+ if ( $line =~ /$cookie->{ 'SEARCH' }/i )
+ {
+ $entry = Maasha::KISS::kiss_entry_parse( $line );
+
+ push @entries, $entry;
+ }
+ }
+
+ close $fh;
+ }
+ }
+
+ return wantarray ? @entries : \@entries;
+}
+
+
+# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+
+1;
+
projects / biopieces.git / commitdiff