code_perl/Maasha/Patscan.pm

   1 package Maasha::Patscan;
   2
   3 # Copyright (C) 2007 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 # This module contains commonly used routines
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use Data::Dumper;
  34 use Maasha::Common;
  35 use Maasha::Seq;
  36 use vars qw ( @ISA @EXPORT );
  37
  38 @ISA = qw( Exporter );
  39
  40
  41 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  42
  43
  44 sub read_patterns
  45 {
  46     # Martin A. Hansen, August 2007.
  47
  48     # Read a list of patterns from file with one pattern
  49     # per line.
  50
  51     my ( $path,   # full path to file
  52        ) = @_;
  53
  54     # Returns list.
  55
  56     my ( $fh, $line, @patterns );
  57
  58     $fh = Maasha::Common::read_open( $path );
  59
  60     while ( $line = <$fh> )
  61     {
  62         $line =~ s/\r\n//g;
  63
  64         next if $line eq "";
  65
  66         push @patterns, $line;
  67     }
  68
  69     close $fh;
  70
  71     return wantarray ? @patterns : \@patterns;
  72 }
  73
  74
  75 sub parse_patterns
  76 {
  77     # Martin A. Hansen, November 2007.
  78
  79     # Splits a string of patterns with out breaking patterns with [,,].
  80
  81     my ( $str,   # comma separated list of patterns
  82        ) = @_;
  83
  84     # Returns a list.
  85
  86     my ( $i, $char, $brackets, @patterns );
  87
  88     $brackets = 0;
  89
  90     for ( $i = 0; $i < length $str; $i++ )
  91     {
  92         $char = substr $str, $i, 1;
  93
  94         if ( $char eq "[" ) {
  95             $brackets++;
  96         } elsif ( $char eq "]" ) {
  97             $brackets--;
  98         } elsif ( $char eq "," and $brackets != 0 ) {
  99             substr $str, $i, 1, '!';
 100         }
 101     }
 102
 103     @patterns = split ",", $str;
 104
 105     map { s/!/,/g } @patterns;
 106
 107     return wantarray ? @patterns : \@patterns;
 108 }
 109
 110
 111 sub parse_scan_result
 112 {
 113     # Martin A. Hansen, January 2007.
 114
 115     # Parses scan_for_matches results
 116
 117     my ( $entry,     # FASTA tuple
 118          $pattern,   # pattern used in patscan
 119        ) = @_;
 120
 121     # Returns hash.
 122
 123     my ( $head, $seq, $beg, $end, $len, $strand, %match );
 124
 125     ( $head, $seq ) = @{ $entry };
 126
 127     if ( $head =~ /^(.+):\[(\d+),(\d+)\]$/ )
 128     {
 129         $head = $1;
 130         $beg  = $2;
 131         $end  = $3;
 132
 133         if ( $beg > $end )
 134         {
 135             ( $beg, $end ) = ( $end, $beg );
 136
 137             $strand = "-";
 138         }
 139         else
 140         {
 141             $strand = "+";
 142         }
 143
 144         $len = $end - $beg + 1;
 145
 146         %match = (
 147             "REC_TYPE"  => "PATSCAN",
 148             "PATTERN"   => $pattern,
 149             "Q_ID"      => $pattern,
 150             "S_ID"      => $head,
 151             "S_BEG"     => $beg - 1, # sfm is 1-based
 152             "S_END"     => $end - 1, # sfm is 1-based
 153             "MATCH_LEN" => $len,
 154             "SCORE"     => 100,
 155             "STRAND"    => $strand,
 156             "HIT"       => $seq,
 157         );
 158     }
 159     else
 160     {
 161         warn qq(WARNING: Could not parse match header->$head<-\n);
 162     }
 163
 164     return wantarray ? %match : \%match;
 165 }
 166
 167
 168 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<