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