code_perl/Maasha/BGB/Track.pm

   1 package Maasha::BGB::Track;
   2
   3 # Copyright (C) 2009 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # Routines for creating Biopieces Browser tracks.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use Maasha::Common;
  35 use Maasha::Calc;
  36 use Maasha::Filesys;
  37 use Maasha::KISS;
  38 use Maasha::Biopieces;
  39 use Maasha::Seq;
  40 use Maasha::BGB::Wiggle;
  41
  42 use vars qw( @ISA @EXPORT );
  43
  44 @ISA = qw( Exporter );
  45
  46 use constant {
  47     S_ID             => 0,
  48     S_BEG            => 1,
  49     S_END            => 2,
  50     Q_ID             => 3,
  51     SCORE            => 4,
  52     STRAND           => 5,
  53     HITS             => 6,
  54     ALIGN            => 7,
  55     BLOCK_COUNT      => 8,
  56     BLOCK_BEGS       => 9,
  57     BLOCK_LENS       => 10,
  58     BLOCK_TYPE       => 11,
  59 };
  60
  61 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  62
  63
  64 sub track_ruler
  65 {
  66     # Martin A. Hansen, November 2009.
  67
  68     # Create a track with a ruler of tics and positions for
  69     # the browser window.
  70
  71     my ( $cookie,   # browser cookie
  72        ) = @_;
  73
  74     # Returns a list.
  75
  76     my ( $beg, $end, $factor, $step, $i, $txt, $x, @ruler );
  77
  78     $beg    = $cookie->{ 'NAV_START' };
  79     $end    = $cookie->{ 'NAV_END' };
  80     $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg );
  81
  82     $step = 10;
  83
  84     while ( ( $end - $beg ) / $step > 20 ) {
  85         $step *= 5;
  86     }
  87
  88     for ( $i = $beg; $i < $end; $i++ )
  89     {
  90         if ( ( $i % $step ) == 0 )
  91         {
  92             $txt = "|" . Maasha::Calc::commify( $i );
  93             $x   = sprintf( "%.0f", ( ( $i - $beg ) * $factor ) + 2 );
  94
  95             if ( $x > 0 and $x + ( $cookie->{ 'RULER_FONT_SIZE' } * length $txt ) < $cookie->{ 'IMG_WIDTH' } )
  96             {
  97                 push @ruler, {
  98                     type      => 'text',
  99                     txt       => $txt,
 100                     font_size => $cookie->{ 'RULER_FONT_SIZE' },
 101                     color     => $cookie->{ 'RULER_COLOR' },
 102                     x1        => $x,
 103                     y1        => $cookie->{ 'TRACK_OFFSET' },
 104                 };
 105             }
 106         }
 107     }
 108
 109     $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
 110
 111     return wantarray ? @ruler : \@ruler;
 112 }
 113
 114
 115 sub track_seq
 116 {
 117     # Martin A. Hansen, November 2009.
 118
 119     # Create a sequence track by extracting the appropriate
 120     # stretch of sequence from the sequence file.
 121
 122     my ( $cookie,   # browser cookie
 123        ) = @_;
 124
 125     # Returns a list.
 126
 127     my ( $file, $fh, $seq, @chars, $factor, $x_offset, $i, @seq_list );
 128
 129     if ( $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 <= 220 )  # only add sequence if less than or equal to 220.
 130     {
 131         $file = path_seq( $cookie );
 132         $fh   = Maasha::Filesys::file_read_open( $file );
 133         $seq  = Maasha::Filesys::file_read( $fh, $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' } - $cookie->{ 'NAV_START' } + 1 );
 134         close $fh;
 135
 136         @chars = split //, $seq;
 137
 138         $factor = $cookie->{ 'IMG_WIDTH' } / @chars;
 139
 140         $x_offset = sprintf( "%.0f", ( $factor / 2 ) - ( $cookie->{ 'SEQ_FONT_SIZE' } / 2 ) );
 141         $x_offset = 0 if $x_offset < 0;
 142
 143         for ( $i = 0; $i < @chars; $i++ )
 144         {
 145             push @seq_list, {
 146                 type      => 'text',
 147                 txt       => $chars[ $i ],
 148                 font_size => $cookie->{ 'SEQ_FONT_SIZE' },
 149                 color     => $cookie->{ 'SEQ_COLOR' },
 150                 x1        => sprintf( "%.0f", $x_offset + $i * $factor ),
 151                 y1        => $cookie->{ 'TRACK_OFFSET' },
 152             };
 153         }
 154
 155         $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'TRACK_SPACE' };
 156
 157         return wantarray ? @seq_list : \@seq_list;
 158     }
 159     else
 160     {
 161         return;
 162     }
 163 }
 164
 165
 166 sub track_feature
 167 {
 168     # Martin A. Hansen, November 2009.
 169
 170     my ( $track,    # path to track data
 171          $cookie,   # cookie hash
 172        ) = @_;
 173
 174     # Returns a list.
 175
 176     my ( $data_wig, $data_kiss, $track_name, $features );
 177
 178     $track_name = ( split "/", $track )[ -1 ];
 179     $track_name =~ s/^\d+_//;
 180     $track_name =~ s/_/ /g;
 181
 182     push @{ $features }, {
 183         type      => 'text',
 184         txt       => $track_name,
 185         font_size => $cookie->{ 'SEQ_FONT_SIZE' },
 186         color     => $cookie->{ 'SEQ_COLOR' },
 187         x1        => 0,
 188         y1        => $cookie->{ 'TRACK_OFFSET' },
 189     };
 190
 191     $cookie->{ 'TRACK_OFFSET' } += 10;
 192
 193     if ( -f "$track/track_data.wig" )
 194     {
 195         $data_wig = Maasha::BGB::Wiggle::wiggle_retrieve( "$track/track_data.wig", $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' } );
 196
 197         push @{ $features }, track_wiggle( $cookie, $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' }, $data_wig );
 198     }
 199     elsif ( -f "$track/track_data.kiss" )
 200     {
 201         $data_kiss = Maasha::KISS::kiss_retrieve( "$track/track_data.kiss", $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' } );
 202
 203         push @{ $features }, track_linear( $cookie, $cookie->{ 'NAV_START' }, $cookie->{ 'NAV_END' }, $data_kiss );
 204     }
 205     else
 206     {
 207         Maasha::Common::error( "Unknown track data type" );
 208     }
 209
 210     return wantarray ? @{ $features } : $features;
 211 }
 212
 213
 214 sub track_wiggle
 215 {
 216     # Martin A. Hansen, February 2010.
 217
 218     # Create a wiggle track.
 219
 220     my ( $cookie,    # hashref with image draw metrics
 221          $beg,       # base window beg
 222          $end,       # base window end
 223          $vals,      # wiggle values
 224        ) = @_;
 225
 226     # Returns a list.
 227
 228     my ( $i, $max_val, $min_val, $factor, $factor_height, $x1, $y1, $x2, $y2, $block_max, $mean, @features );
 229
 230     $cookie->{ 'TRACK_OFFSET' } += 10;
 231
 232     $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg );
 233
 234     ( $min_val, $max_val ) = Maasha::Calc::minmax( $vals );
 235
 236     if ( $max_val == 0 ) {
 237         $factor_height = $cookie->{ 'WIGGLE_HEIGHT' } / 1;
 238     } else {
 239         $factor_height = $cookie->{ 'WIGGLE_HEIGHT' } / $max_val;
 240     }
 241
 242     $block_max = 0;
 243
 244     $x1 = 0;
 245     $y1 = $cookie->{ 'TRACK_OFFSET' } + $cookie->{ 'WIGGLE_HEIGHT' };
 246
 247     for ( $i = 0; $i < scalar @{ $vals }; $i++ )
 248     {
 249         $block_max = Maasha::Calc::max( $block_max, $vals->[ $i ] );
 250
 251         $x2 = int( $i * $factor );
 252
 253         if ( $x2 > $x1 )
 254         {
 255             $y2 = $cookie->{ 'TRACK_OFFSET' } + $cookie->{ 'WIGGLE_HEIGHT' } - sprintf( "%.0f", $block_max * $factor_height );
 256
 257             push @features, {
 258                 type       => 'wiggle',
 259                 color      => $cookie->{ 'FEAT_COLOR' },
 260                 line_width => 1,
 261                 x1         => $x1,
 262                 y1         => $y1,
 263                 x2         => $x2,
 264                 y2         => $y2,
 265             };
 266
 267             $x1 = $x2;
 268             $y1 = $y2;
 269
 270             $block_max = 0;
 271         }
 272     }
 273
 274     $y2 = $cookie->{ 'TRACK_OFFSET' } + $cookie->{ 'WIGGLE_HEIGHT' };
 275
 276     push @features, {
 277         type       => 'wiggle',
 278         color      => $cookie->{ 'FEAT_COLOR' },
 279         line_width => 1,
 280         x1         => $x1,
 281         y1         => $y1,
 282         x2         => $x2,
 283         y2         => $y2,
 284     };
 285
 286     unshift @features, {
 287         type      => 'text',
 288         txt       => "  min: " . Maasha::Calc::commify( $min_val ) . " max: " . Maasha::Calc::commify( $max_val ),
 289         font_size => $cookie->{ 'SEQ_FONT_SIZE' } - 2,
 290         color     => $cookie->{ 'SEQ_COLOR' },
 291         x1        => 0,
 292         y1        => $cookie->{ 'TRACK_OFFSET' } - 5,
 293     };
 294
 295     $cookie->{ 'TRACK_OFFSET' } += $cookie->{ 'WIGGLE_HEIGHT' } + $cookie->{ 'TRACK_SPACE' };
 296
 297     return wantarray ? @features : \@features;
 298 }
 299
 300
 301 sub track_linear
 302 {
 303     # Martin A. Hansen, November 2009.
 304
 305     # Create a linear feature track where the granularity depends
 306     # on the lenght of the features and the browser window width.
 307
 308     my ( $cookie,    # hashref with image draw metrics
 309          $beg,       # base window beg
 310          $end,       # base window end
 311          $entries,   # list of unsorted KISS entries
 312        ) = @_;
 313
 314     # Returns a list.
 315
 316     my ( $factor, $entry, $y_step, @ladder, $y_max, $w, $x1, $y1, $x2, $y2, $feature, @features );
 317
 318     $factor = $cookie->{ 'IMG_WIDTH' } / ( $end - $beg );
 319     $y_step = 0;
 320     $y_max  = 0;
 321
 322     foreach $entry ( @{ $entries } )
 323     {
 324         $w = sprintf( "%.0f", ( $entry->[ S_END ] - $entry->[ S_BEG ] + 1 ) * $factor );
 325
 326         if ( $w >= 1 )
 327         {
 328             $x1 = sprintf( "%.0f", ( $entry->[ S_BEG ] - $beg ) * $factor );
 329
 330             for ( $y_step = 0; $y_step < @ladder; $y_step++ ) {
 331                 last if $x1 >= $ladder[ $y_step ] + 1;
 332             }
 333
 334             $y1 = $cookie->{ 'TRACK_OFFSET' } + ( ( 1.1 + $cookie->{ 'FEAT_WIDTH' } ) * $y_step );
 335
 336             $feature = {
 337                 line_width => $cookie->{ 'FEAT_WIDTH' },
 338                 color      => $cookie->{ 'FEAT_COLOR' },
 339                 title      => "Q_ID: $entry->[ Q_ID ] S_BEG: $entry->[ S_BEG ] S_END: $entry->[ S_END ]",
 340                 q_id       => $entry->[ Q_ID ],
 341                 s_beg      => $entry->[ S_BEG ],
 342                 s_end      => $entry->[ S_END ],
 343                 strand     => $entry->[ STRAND ],
 344                 x1         => $x1,
 345                 y1         => $y1,
 346                 x2         => $x1 + $w,
 347                 y2         => $y1 + $cookie->{ 'FEAT_WIDTH' },
 348             };
 349
 350             if ( $entry->[ STRAND ] eq '+' or $entry->[ STRAND ] eq '-' ) {
 351                 $feature->{ 'type' } = 'arrow';
 352             } else {
 353                 $feature->{ 'type' } = 'rect';
 354             }
 355
 356             push @features, $feature;
 357
 358             $y_max = Maasha::Calc::max( $y_max, $y_step * ( 1.1 + $cookie->{ 'FEAT_WIDTH' } ) );
 359
 360             push @features, feature_align( $entry, $beg, $y1, $factor, $cookie->{ 'FEAT_WIDTH' } ) if $entry->[ ALIGN ] ne '.';
 361
 362             $ladder[ $y_step ] = $x1 + $w;
 363         }
 364     }
 365
 366     $cookie->{ 'TRACK_OFFSET' } += $y_max + $cookie->{ 'TRACK_SPACE' };
 367
 368     return wantarray ? @features : \@features;
 369 }
 370
 371
 372 sub feature_align
 373 {
 374     # Martin A. Hansen, November 2009.
 375
 376     # Add to feature track alignment info if the granularity is
 377     # sufficient.
 378     # TODO: The printing of chars is imprecise.
 379
 380     my ( $entry,         # Partial KISS entry
 381          $beg,           # base window beg
 382          $y_offset,      # y axis draw offset
 383          $factor,        # scale factor
 384          $feat_height,   # hight of feature in pixels
 385        ) = @_;
 386
 387     # Returns a list.
 388
 389     my ( $w, $align, $pos, $nt_before, $nt_after, $x1, @features );
 390
 391     $w = sprintf( "%.0f", 1 * $factor );
 392
 393     if ( $w >= 1 )
 394     {
 395         foreach $align ( split /,/, $entry->[ ALIGN ] )
 396         {
 397             if ( $align =~ /(\d+):([ATCGN-])>([ATCGN-])/ )
 398             {
 399                 $pos       = $1;
 400                 $nt_before = $2;
 401                 $nt_after  = $3;
 402             }
 403             else
 404             {
 405                 Maasha::Common::error( qq(BAD align descriptor: "$align") );
 406             }
 407
 408             $x1 = sprintf( "%.0f", ( $entry->[ S_BEG ] + $pos - $beg ) * $factor );
 409
 410             push @features, {
 411                 type       => 'rect',
 412                 line_width => $feat_height,
 413                 color      => [ 1, 0, 0 ],
 414                 title      => $align,
 415                 x1         => $x1,
 416                 y1         => $y_offset,
 417                 x2         => $x1 + $w,
 418                 y2         => $y_offset + $feat_height,
 419             };
 420
 421             if ( $w > $feat_height )
 422             {
 423                 push @features, {
 424                     type       => 'text',
 425                     font_size  => $feat_height + 2,
 426                     color      => [ 0, 0, 0 ],
 427                     txt        => $nt_after,
 428                     x1         => $x1 + sprintf( "%.0f", ( $w / 2 ) ) - $feat_height / 2,
 429                     y1         => $y_offset + $feat_height,
 430                 };
 431             }
 432         }
 433     }
 434
 435     return wantarray ? @features : \@features;
 436 }
 437
 438
 439 sub track_feature_histogram
 440 {
 441     # Martin A. Hansen, November 2009.
 442
 443     # Create a feature track as a histogram using information
 444     # from the index only thus avoiding to load features from the
 445     # file.
 446
 447     my ( $cookie,   # hashref with image draw metrics
 448          $min,      # minimum base position
 449          $max,      # maximum base position
 450          $blocks,   # list of blocks
 451        ) = @_;
 452
 453     # Returns a list.
 454
 455     my ( $hist_height, $bucket_width, $bucket_count, $min_bucket, $factor, $factor_heigth, $max_height, $block, $bucket_beg, $bucket_end, $i, @buckets, $h, $x, @hist );
 456
 457     return if $max <= $min;
 458
 459     $hist_height  = 100;   # pixels
 460     $bucket_width = 5;
 461     $bucket_count = $cookie->{ 'IMG_WIDTH' } / $bucket_width;
 462     $factor       = ( $cookie->{ 'IMG_WIDTH' } / $bucket_width ) / ( $max - $min );
 463
 464     $min_bucket = 999999999;
 465     $max_height = 0;
 466
 467     foreach $block ( @{ $blocks } )
 468     {
 469         $bucket_beg = int( $block->{ 'BEG' } * $factor );
 470         $bucket_end = int( $block->{ 'END' } * $factor );
 471
 472         $min_bucket = Maasha::Calc::min( $min_bucket, $bucket_beg );
 473
 474         for ( $i = $bucket_beg; $i < $bucket_end; $i++ )
 475         {
 476             $buckets[ $i ] += $block->{ 'COUNT' };
 477
 478             $max_height = Maasha::Calc::max( $max_height, $buckets[ $i ] );
 479         }
 480     }
 481
 482     if ( $max_height > 0 )
 483     {
 484         $factor_heigth = $hist_height / $max_height;
 485
 486         $x = 0;
 487
 488         for ( $i = $min_bucket; $i < @buckets; $i++ )
 489         {
 490             if ( defined $buckets[ $i ] )
 491             {
 492                 $h = sprintf( "%.0f", $buckets[ $i ] * $factor_heigth );
 493
 494                 if ( $h >= 1 )
 495                 {
 496                     push @hist, {
 497                         type       => 'line',
 498                         line_width => $bucket_width,
 499                         color      => $cookie->{ 'FEAT_COLOR' },
 500                         title      => "Features: $buckets[ $i ]",
 501                         x1         => $x,
 502                         y1         => $cookie->{ 'TRACK_OFFSET' } + $hist_height,
 503                         x2         => $x,
 504                         y2         => $cookie->{ 'TRACK_OFFSET' } + $hist_height - $h,
 505                     };
 506                 }
 507             }
 508
 509             $x += $bucket_width;
 510         }
 511     }
 512
 513     $cookie->{ 'TRACK_OFFSET' } += $hist_height + $cookie->{ 'TRACK_SPACE' };
 514
 515     return wantarray ? @hist : \@hist;
 516 }
 517
 518
 519 sub dna_get
 520 {
 521     # Martin A. Hansen, November 2009.
 522
 523     # Returns the sequence from the contig in the beg/end interval
 524     # contained in the cookie.
 525
 526     my ( $cookie,   # cookie hash
 527        ) = @_;
 528
 529     # Returns a string.
 530
 531     my ( $path, $fh, $beg, $end, $len, $dna );
 532
 533     $path = path_seq( $cookie );
 534
 535     $beg = $cookie->{ 'S_BEG' };
 536     $end = $cookie->{ 'S_END' };
 537     $beg =~ tr/,//d;
 538     $end =~ tr/,//d;
 539     $len = $end - $beg + 1;
 540
 541
 542     $fh = Maasha::Filesys::file_read_open( $path );
 543
 544     $dna = Maasha::Filesys::file_read( $fh, $beg, $len );
 545
 546     $dna = Maasha::Seq::dna_revcomp( $dna ) if $cookie->{ 'STRAND' } eq '-';
 547
 548     Maasha::Seq::wrap( \$dna, 100 );
 549
 550     close $fh;
 551
 552     return $dna;
 553 }
 554
 555
 556 sub path_seq
 557 {
 558     # Martin A. Hansen, November 2009.
 559
 560     # Returns the path to the sequence file for a specified
 561     # contig as written in the cookie.
 562
 563     my ( $cookie,   # cookie hash
 564        ) = @_;
 565
 566     # Returns a string.
 567
 568     my ( $path );
 569
 570     die qq(ERROR: no USER in cookie.\n)     if not $cookie->{ 'USER' };
 571     die qq(ERROR: no CLADE in cookie.\n)    if not $cookie->{ 'CLADE' };
 572     die qq(ERROR: no GENOME in cookie.\n)   if not $cookie->{ 'GENOME' };
 573     die qq(ERROR: no ASSEMBLY in cookie.\n) if not $cookie->{ 'ASSEMBLY' };
 574     die qq(ERROR: no CONTIG in cookie.\n)   if not $cookie->{ 'CONTIG' };
 575
 576     $path = join( "/",
 577         $cookie->{ 'DATA_DIR' },
 578         "Users",
 579         $cookie->{ 'USER' },
 580         $cookie->{ 'CLADE' },
 581         $cookie->{ 'GENOME' },
 582         $cookie->{ 'ASSEMBLY' },
 583         $cookie->{ 'CONTIG' },
 584         "Sequence",
 585         "sequence.txt"
 586     );
 587
 588     die qq(ERROR: no such file: "$path".\n) if not -e $path;
 589
 590     return $path;
 591 }
 592
 593
 594 sub search_tracks
 595 {
 596     # Martin A. Hansen, December 2009.
 597
 598     # Uses grep to search all tracks in all contigs
 599     # for a given pattern and return a list of KISS entries.
 600
 601     my ( $cookie,   # cookie hash
 602        ) = @_;
 603
 604     # Returns a list.
 605
 606     my ( $search_track, $search_term, $contig, @tracks, $track, $file, $line, $out_file, $fh, $entry, @entries, $track_name );
 607
 608     if ( $cookie->{ 'SEARCH' } =~ /^(.+)\s+track:\s*(.+)/i )
 609     {
 610         $search_term  = $1;
 611         $search_track = $2;
 612
 613         $search_track =~ tr/ /_/;
 614     }
 615     else
 616     {
 617         $search_term = $cookie->{ 'SEARCH' };
 618     }
 619
 620     foreach $contig ( @{ $cookie->{ 'LIST_CONTIG' } } )
 621     {
 622         $cookie->{ 'CONTIG' } = $contig;
 623
 624         push @tracks, list_track_dir( $cookie->{ 'USER' }, $cookie->{ 'CLADE' }, $cookie->{ 'GENOME' }, $cookie->{ 'ASSEMBLY' }, $cookie->{ 'CONTIG' } );
 625     }
 626
 627     foreach $track ( @tracks )
 628     {
 629         if ( $search_track )
 630         {
 631             $track_name = ( split "/", $track )[ -1 ];
 632
 633             next if $track_name !~ /$search_track/i;
 634         }
 635
 636         $file = "$track/track_data.kiss";
 637
 638         if ( -f $file )
 639         {
 640             $fh = Maasha::Filesys::file_read_open( $file );
 641
 642             while ( $line = <$fh> )
 643             {
 644                 chomp $line;
 645
 646                 if ( $line =~ /$search_term/i )
 647                 {
 648                     $entry = Maasha::KISS::kiss_entry_parse( $line );
 649                     $entry = Maasha::KISS::kiss2biopiece( $entry );
 650                     push @entries, $entry;
 651                 }
 652             }
 653
 654             close $fh;
 655         }
 656     }
 657
 658     return wantarray ? @entries : \@entries;
 659 }
 660
 661
 662 sub list_user_dir
 663 {
 664     # Martin A. Hansen, December 2009.
 665
 666     # List all users directories in the ~/Data/Users
 667     # directory with full path.
 668
 669     # Returns a list.
 670
 671     my ( @dirs, @users );
 672
 673     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 674
 675     @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users" );
 676
 677     @users = grep { $_ !~ /\/\.\.?$/ } @dirs;
 678
 679     return wantarray ? @users : \@users;
 680 }
 681
 682
 683 sub list_users
 684 {
 685     # Martin A. Hansen, December 2009.
 686
 687     # List all users in ~/Data/Users
 688
 689     # Returns a list.
 690
 691     my ( @dirs, $dir, @users );
 692
 693     @dirs = list_user_dir();
 694
 695     foreach $dir ( @dirs ) {
 696         push @users, ( split "/", $dir )[ -1 ];
 697     }
 698
 699     return wantarray ? @users : \@users;
 700 }
 701
 702
 703 sub list_clade_dir
 704 {
 705     # Martin A. Hansen, December 2009.
 706
 707     # List all clades for a given user in ~/Data/Users
 708
 709     my ( $user,   # user for which to return clades
 710        ) = @_;
 711
 712     # Returns a list.
 713
 714     my ( @dirs, @clades );
 715
 716     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 717
 718     @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user" );
 719
 720     @clades = grep { $_ !~ /\/\.\.?$/ } @dirs;
 721
 722     return wantarray ? @clades : \@clades;
 723 }
 724
 725
 726 sub list_clades
 727 {
 728     # Martin A. Hansen, December 2009.
 729
 730     # List all clades for a given user in ~/Data/Users
 731
 732     my ( $user,   # user for which to return clades
 733        ) = @_;
 734
 735     # Returns a list.
 736
 737     my ( @dirs, $dir, @clades );
 738
 739     @dirs = list_clade_dir( $user );
 740
 741     foreach $dir ( @dirs ) {
 742         push @clades, ( split "/", $dir )[ -1 ];
 743     }
 744
 745     return wantarray ? @clades : \@clades;
 746 }
 747
 748
 749 sub list_genome_dir
 750 {
 751     # Martin A. Hansen, December 2009.
 752
 753     # List all genomes for a given user and clade in ~/Data/Users
 754
 755     my ( $user,    # user for which to return genomes
 756          $clade,   # clade for which to return genomes
 757        ) = @_;
 758
 759     # Returns a list.
 760
 761     my ( @dirs, @genomes );
 762
 763     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 764
 765     @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade" );
 766
 767     @genomes = grep { $_ !~ /\/\.\.?$/ } @dirs;
 768
 769     return wantarray ? @genomes : \@genomes;
 770 }
 771
 772
 773 sub list_genomes
 774 {
 775     # Martin A. Hansen, December 2009.
 776
 777     # List all genomes for a given user and clade in ~/Data/Users
 778
 779     my ( $user,    # user for which to return genomes
 780          $clade,   # clade for which to return genomes
 781        ) = @_;
 782
 783     # Returns a list.
 784
 785     my ( @dirs, $dir, @genomes );
 786
 787     @dirs = list_genome_dir( $user, $clade );
 788
 789     foreach $dir ( @dirs ) {
 790         push @genomes, ( split "/", $dir )[ -1 ];
 791     }
 792
 793     return wantarray ? @genomes : \@genomes;
 794 }
 795
 796
 797 sub list_assembly_dir
 798 {
 799     # Martin A. Hansen, December 2009.
 800
 801     # List all assemblies for a given user and clade and genome in ~/Data/Users
 802
 803     my ( $user,     # user for which to return assemblies
 804          $clade,    # clade for which to return assemblies
 805          $genome,   # genome for which to return assemblies
 806        ) = @_;
 807
 808     # Returns a list.
 809
 810     my ( @dirs, @assemblies );
 811
 812     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 813
 814     if ( $user and $clade and $genome ) {
 815         @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome" );
 816     }
 817
 818     @assemblies = grep { $_ !~ /\/\.\.?$/ } @dirs;
 819
 820     return wantarray ? @assemblies : \@assemblies;
 821 }
 822
 823
 824 sub list_assemblies
 825 {
 826     # Martin A. Hansen, December 2009.
 827
 828     # List all assemblies for a given user and clade and genome in ~/Data/Users
 829
 830     my ( $user,     # user for which to return assemblies
 831          $clade,    # clade for which to return assemblies
 832          $genome,   # genome for which to return assemblies
 833        ) = @_;
 834
 835     # Returns a list.
 836
 837     my ( @dirs, $dir, @assemblies );
 838
 839     @dirs = list_assembly_dir( $user, $clade, $genome );
 840
 841     foreach $dir ( @dirs ) {
 842         push @assemblies, ( split "/", $dir )[ -1 ];
 843     }
 844
 845     return wantarray ? @assemblies : \@assemblies;
 846 }
 847
 848
 849 sub list_contig_dir
 850 {
 851     # Martin A. Hansen, December 2009.
 852
 853     # List all assemblies for a given user->clade->genome->assembly in ~/Data/Users
 854
 855     my ( $user,       # user for which to return contigs
 856          $clade,      # clade for which to return contigs
 857          $genome,     # genome for which to return contigs
 858          $assembly,   # assembly for which to return contigs
 859        ) = @_;
 860
 861     # Returns a list.
 862
 863     my ( @dirs, @contigs );
 864
 865     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 866
 867     if ( $user and $clade and $genome and $assembly ) {
 868         @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome/$assembly" );
 869     }
 870
 871     @contigs = grep { $_ !~ /\/\.\.?$/ } @dirs;
 872
 873     return wantarray ? @contigs : \@contigs;
 874 }
 875
 876
 877 sub list_contigs
 878 {
 879     # Martin A. Hansen, December 2009.
 880
 881     # List all contigs for a given user->clade->genome->assembly in ~/Data/Users
 882
 883     my ( $user,       # user for which to return contigs
 884          $clade,      # clade for which to return contigs
 885          $genome,     # genome for which to return contigs
 886          $assembly,   # assembly for which to return contigs
 887        ) = @_;
 888
 889     # Returns a list.
 890
 891     my ( @dirs, $dir, @contigs );
 892
 893     @dirs = list_contig_dir( $user, $clade, $genome, $assembly );
 894
 895     foreach $dir ( @dirs ) {
 896         push @contigs, ( split "/", $dir )[ -1 ];
 897     }
 898
 899     return wantarray ? @contigs : \@contigs;
 900 }
 901
 902
 903 sub list_track_dir
 904 {
 905     # Martin A. Hansen, December 2009.
 906
 907     # List all tracks for a given user->clade->genome->assembly->contig in ~/Data/Users
 908
 909     my ( $user,       # user for which to return tracks
 910          $clade,      # clade for which to return tracks
 911          $genome,     # genome for which to return tracks
 912          $assembly,   # assembly for which to return tracks
 913          $contig,     # contig for which to return tracks
 914        ) = @_;
 915
 916     # Returns a list.
 917
 918     my ( @dirs, @tracks );
 919
 920     Maasha::Common::error( 'BP_WWW not set in environment' ) if not $ENV{ 'BP_WWW' };
 921
 922     if ( -d "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome/$assembly/$contig/Tracks" ) {
 923         @dirs = Maasha::Filesys::ls_dirs( "$ENV{ 'BP_WWW' }/Data/Users/$user/$clade/$genome/$assembly/$contig/Tracks" );
 924     }
 925
 926     @tracks = grep { $_ !~ /\/\.\.?$/ } @dirs;
 927
 928     return wantarray ? @tracks : \@tracks;
 929 }
 930
 931
 932 sub list_tracks
 933 {
 934     # Martin A. Hansen, December 2009.
 935
 936     # List all tracks for a given user->clade->genome->assembly->contig in ~/Data/Users
 937
 938     my ( $user,       # user for which to return tracks
 939          $clade,      # clade for which to return tracks
 940          $genome,     # genome for which to return tracks
 941          $assembly,   # assembly for which to return tracks
 942          $contig,     # contig for which to return tracks
 943        ) = @_;
 944
 945     # Returns a list.
 946
 947     my ( @dirs, $dir, @tracks );
 948
 949     @dirs = list_track_dir( $user, $clade, $genome, $assembly, $contig );
 950
 951     foreach $dir ( @dirs ) {
 952         push @tracks, ( split "/", $dir )[ -1 ];
 953     }
 954
 955     return wantarray ? @tracks : \@tracks;
 956 }
 957
 958
 959 sub max_track
 960 {
 961     # Martin A. Hansen, December 2009.
 962
 963     # Traverses all contigs for a given user->clade->genome->assembly and
 964     # returns the maximum track's prefix value eg. 20 for 20_Genbank.
 965
 966     my ( $user,
 967          $clade,
 968          $genome,
 969          $assembly
 970        ) = @_;
 971
 972     # Returns an integer
 973
 974     my ( @contigs, $contig, @tracks, $max );
 975
 976     @contigs = list_contigs( $user, $clade, $genome, $assembly );
 977
 978     foreach $contig ( @contigs ) {
 979         push @tracks, list_tracks( $user, $clade, $genome, $assembly, $contig );
 980     }
 981
 982     @tracks = sort @tracks;
 983
 984     if ( scalar @tracks > 0 and $tracks[ -1 ] =~ /^(\d+)/ ) {
 985         $max = $1;
 986     } else {
 987         $max = 0;
 988     }
 989
 990     return $max;
 991 }
 992
 993
 994 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 995
 996 1;
 997
 998 __END__
 999
1000
1001 sub search_tracks_nc
1002 {
1003     # Martin A. Hansen, December 2009.
1004
1005     # Uses grep to search all tracks in all contigs
1006     # for a given pattern and return a list of KISS entries.
1007
1008     my ( $cookie,   # cookie hash
1009        ) = @_;
1010
1011     # Returns a list.
1012
1013     my ( $search_track, $search_term, $contig, @tracks, $track, $file, @features, $track_name, $nc_list );
1014
1015     if ( $cookie->{ 'SEARCH' } =~ /^(.+)\s+track:\s*(.+)/i )
1016     {
1017         $search_term  = $1;
1018         $search_track = $2;
1019
1020         $search_track =~ tr/ /_/;
1021     }
1022     else
1023     {
1024         $search_term = $cookie->{ 'SEARCH' };
1025     }
1026
1027     foreach $contig ( @{ $cookie->{ 'LIST_CONTIG' } } )
1028     {
1029         $cookie->{ 'CONTIG' } = $contig;
1030
1031         push @tracks, list_track_dir( $cookie->{ 'USER' }, $cookie->{ 'CLADE' }, $cookie->{ 'GENOME' }, $cookie->{ 'ASSEMBLY' }, $cookie->{ 'CONTIG' } );
1032     }
1033
1034     foreach $track ( @tracks )
1035     {
1036         if ( $search_track )
1037         {
1038             $track_name = ( split "/", $track )[ -1 ];
1039
1040             next if $track_name !~ /$search_track/i;
1041         }
1042
1043         $file = "$track/track_data.kiss.json";
1044
1045         if ( -f $file )
1046         {
1047             $nc_list  = Maasha::NClist::nc_list_retrieve( $file );
1048             push @features, Maasha::NClist::nc_list_search( $nc_list, $search_term, 12 );
1049         }
1050     }
1051
1052     return wantarray ? @features : \@features;
1053 }
1054
1055
1056
1057 sub track_feature
1058 {
1059     # Martin A. Hansen, November 2009.
1060
1061     # Create a track with features. If there are more than $cookie->FEAT_MAX
1062     # features the track created will be a histogram, else linear.
1063
1064     my ( $track,    # path to kiss file with track data
1065          $cookie,   # cookie hash
1066        ) = @_;
1067
1068     # Returns a list.
1069
1070     my ( $index, $count, $track_name, $start, $end, $entries, $features );
1071
1072     $start = $cookie->{ 'NAV_START' };
1073     $end   = $cookie->{ 'NAV_END' };
1074
1075     $index = Maasha::KISS::kiss_index_retrieve( "$track/track_data.kiss.index" );
1076     $count = Maasha::KISS::kiss_index_count( $index, $start, $end );
1077
1078     $track_name = ( split "/", $track )[ -1 ];
1079     $track_name =~ s/^\d+_//;
1080     $track_name =~ s/_/ /g;
1081
1082     $features = [ {
1083         type      => 'text',
1084         txt       => $track_name,
1085         font_size => $cookie->{ 'SEQ_FONT_SIZE' },
1086         color     => $cookie->{ 'SEQ_COLOR' },
1087         x1        => 0,
1088         y1        => $cookie->{ 'TRACK_OFFSET' },
1089     } ];
1090
1091     $cookie->{ 'TRACK_OFFSET' } += 10;
1092
1093     if ( $count > $cookie->{ 'FEAT_MAX' } )
1094     {
1095         $entries  = Maasha::KISS::kiss_index_get_blocks( $index, $start, $end );
1096         push @{ $features }, track_feature_histogram( $cookie, $start, $end, $entries );
1097     }
1098     else
1099     {
1100         $entries  = Maasha::KISS::kiss_index_get_entries( "$track/track_data.kiss", $index, $start, $end );
1101         push @{ $features }, track_feature_linear( $cookie, $start, $end, $entries );
1102     }
1103
1104     return wantarray ? @{ $features } : $features;
1105 }