From: martinahansen Date: Mon, 14 Dec 2009 08:58:40 +0000 (+0000) Subject: replacing Bbrowser with BGB X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=8a7e9c5322e1a0dd57ec68fcd4c504f73f45604b;p=biopieces.git replacing Bbrowser with BGB git-svn-id: http://biopieces.googlecode.com/svn/trunk@804 74ccb610-7750-0410-82ae-013aeee3265d --- diff --git a/code_perl/Maasha/BBrowser/Draw.pm b/code_perl/Maasha/BBrowser/Draw.pm deleted file mode 100644 index d83ae2e..0000000 --- a/code_perl/Maasha/BBrowser/Draw.pm +++ /dev/null @@ -1,179 +0,0 @@ -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; - - diff --git a/code_perl/Maasha/BBrowser/Session.pm b/code_perl/Maasha/BBrowser/Session.pm deleted file mode 100644 index 132d5cc..0000000 --- a/code_perl/Maasha/BBrowser/Session.pm +++ /dev/null @@ -1,132 +0,0 @@ -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; diff --git a/code_perl/Maasha/BBrowser/Track.pm b/code_perl/Maasha/BBrowser/Track.pm deleted file mode 100644 index 19602bd..0000000 --- a/code_perl/Maasha/BBrowser/Track.pm +++ /dev/null @@ -1,584 +0,0 @@ -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; - diff --git a/code_perl/Maasha/BGB/Draw.pm b/code_perl/Maasha/BGB/Draw.pm new file mode 100644 index 0000000..d83ae2e --- /dev/null +++ b/code_perl/Maasha/BGB/Draw.pm @@ -0,0 +1,179 @@ +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; + + diff --git a/code_perl/Maasha/BGB/Session.pm b/code_perl/Maasha/BGB/Session.pm new file mode 100644 index 0000000..132d5cc --- /dev/null +++ b/code_perl/Maasha/BGB/Session.pm @@ -0,0 +1,132 @@ +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; diff --git a/code_perl/Maasha/BGB/Track.pm b/code_perl/Maasha/BGB/Track.pm new file mode 100644 index 0000000..19602bd --- /dev/null +++ b/code_perl/Maasha/BGB/Track.pm @@ -0,0 +1,584 @@ +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; +