Найти несколько подстрок в строках и местоположение записи

Question

Ниже приведен скрипт для поиска последовательных подстрок в строках.

use strict;
use warnings;

my $file="Sample.txt";
open(DAT, $file) || die("Could not open file!");

#worry about these later
#my $regexp1 = "motif1";
#my $regexp2 = "motif2";
#my $regexp3 = "motif3";
#my $regexp4 = "motif4";

my $sequence;

while (my $line = <DAT>) {
    if ($line=~ /(HDWFLSFKD)/g){
        {
        print "its found index location: ",
        pos($line), "-",  pos($line)+length($1), "\n";        
        }
        if ($line=~ /(HD)/g){
                print "motif found and its locations is: \n";
                pos($line), "-", pos($line)+length($1), "\n\n";
                }
                if ($line=~ /(K)/g){
                        print "motif found and its location is: \n";
                        pos($line), "-",pos($line)+length($1), "\n\n";
                        }
                        if ($line=~ /(DD)/g){
                                print "motif found and its location is: \n";
                                pos($line), "-", pos($line)+length($1), "\n\n";
                                }
}else {
        $sequence .= $line;
        print "came in else\n";
    }
}

Соответствует substring1 со строкой и выводит позицию, в которой substring1 соответствует. Проблема заключается в поиске остальных подстрок. Для substrings2 он начинается снова с начала строки (вместо того, чтобы начинать с позиции, где была найдена substring1). Проблема состоит в том, что каждый раз, когда он вычисляет позицию, он начинается с начала строки, а не с позиции ранее найденной подстроки. Поскольку подстроки являются последовательными подстрокой1, подстрокой2, подстрокой3, подстрокой4, их положения должны располагаться после предыдущего соответственно.

Answer 1

Попробуйте эту программу Perl

use strict;
use warnings;
use feature qw'say';

my $file="Sample.txt";
open( my $dat, '<', $file) || die("Could not open file!");

my @regex = qw(
  HDWFLSFKD
  HD
  K
  DD
);

my $sequence;

while( my $line = <$dat> ){
  chomp $line;

  say 'Line: ', $.;

  # reset the position of variable $line
  # pos is an lvalue subroutine
  pos $line = 0;

  for my $regex ( @regex ){
    $regex = quotemeta $regex;

    if( scalar $line =~ / \G (.*?) ($regex) /xg ){
      say $regex, ' found at location (', $-[2], '-', $+[2], ')';
      if( $1 ){
        say "    but skipped: \"$1\" at location ($-[1]-$+[1])";
      }
    }else{
      say 'Unable to find ', $regex;

      # end loop
      last;
    }
  }
}

Answer 2

Я не эксперт по Perl, но вы можете использовать $ - и $ + для отслеживания местоположения индекса для последнего найденного соответствия регулярному выражению.
Ниже приведен код, построенный поверх вашего кода, который объясняет это.

use strict;
use warnings;


my $file="sample.txt";
open(DAT, $file) || die("Could not open file!");

open (OUTPUTFILE, '>data.txt');

my $sequence;
my $someVar = 0;
my $sequenceNums = 1;

my $motif1 = "(HDWFLSFKD)";
my $motif2 = "(HD)";
my $motif3 = "(K)";
my $motif4 = "(DD)";

while (my $line = <DAT>) 
{
    $someVar = 0;
    print "\nSequence $sequenceNums: $line\n";
    print OUTPUTFILE "\nSequence $sequenceNums: $line\n";
        if ($line=~ /$motif1/g)
        {
                &printStuff($sequenceNums, "motif1", $motif1, "$-[0]-$+[0]");
                $someVar = 1;
        }


        if ($line=~ /$motif2/g and $someVar == 1)
        {
                &printStuff($sequenceNums, "motif2", $motif2, "$-[0]-$+[0]");
                $someVar = 2;
        }

        if ($line=~ /$motif3/g and $someVar == 2)
        {
                &printStuff($sequenceNums, "motif3", $motif4, "$-[0]-$+[0]");
                $someVar = 3;
        }

        if ($line=~ /$motif4/g and $someVar == 3)
        {
                &printStuff($sequenceNums, "motif4", $motif4, "$-[0]-$+[0]");
        }

        else 
        {
            $sequence .= $line;

            if ($someVar == 0)
            {
                &printWrongStuff($sequenceNums, "motif1", $motif1);
            }
            elsif ($someVar == 1)
            {
            &printWrongStuff($sequenceNums, "motif2", $motif2);
            }
            elsif ($someVar == 2)
            {
            &printWrongStuff($sequenceNums, "motif3", $motif3);
            }
            elsif ($someVar == 3)
            {
            &printWrongStuff($sequenceNums, "motif4", $motif4);
            }
        }
        $sequenceNums++;
}

sub printStuff
{
            print "Sequence: $_[0] $_[1]: $_[2] index location: $_[3] \n";
            print OUTPUTFILE "Sequence: $_[0]  $_[1]: $_[2] index location: $_[3]\n";
}

sub printWrongStuff
{
            print "Sequence: $_[0] $_[1]: $_[2] was not found\n";
            print OUTPUTFILE "Sequence: $_[0] $_[1]: $_[2] was not found\n";    

}

close (OUTPUTFILE);
close (DAT);

Пример ввода:

MLTSHQKKF HDWFLSFKD SNNYN HD S K QNHSIK DD IFNRFNHYIYNDLGIRTIA MLTSHQKKFSNNYNSKQNHSIKDIFNRFNHYIYNDLGIRTIA MLTSHQKKFSNNYNSK HDWFLSFKD QNHSIKDIFNRFNHYIYNDL

Answer 3

Вы действительно должны прочитать

• perldoc perlre
• perldoc perlreref
• perldoc perlretut

Вам нужны специальные переменные @ - и @ +, если вам нужны позиции. Не нужно пытаться вычислить их самостоятельно.

#!/usr/bin/perl

use strict;
use warnings;

use List::MoreUtils qw( each_array );

my $source = 'AAAA   BBCCC   DD  E      FFFFF';
my $pattern = join '\s*', map { "($_+)" } qw( A B C D E F );



if ( $source =~ /$pattern/ ) {
    my $it = each_array @-, @+;

    $it->(); # discard overall match information;

    while ( my ($start, $end) = $it->() ) {
        printf "Start: %d - Length: %d\n", $start, $end - $start;
    }
}

Start: 0 - Length: 4
Start: 7 - Length: 2
Start: 9 - Length: 3
Start: 15 - Length: 2
Start: 19 - Length: 1
Start: 26 - Length: 5

Answer 4

Для совпадения с местом окончания последнего совпадения используйте \G. perldoc perlre говорит (но сначала обратитесь к руководству по вашей версии установки):

Утверждение "\ G" можно использовать для цепочка глобальных совпадений (используя «m // g»), как описано в "Regexp Quote-Like Операторы "в perlop. Это также полезно при написании "lex" -подобно сканеры, когда у вас есть несколько шаблоны, которые вы хотите соответствовать против последующих подстрок вашего строка, см. предыдущую ссылку. Фактическое местоположение, где "\ G" будет соответствие может также зависеть от использования "pos ()" как lvalue: см. "pos" в perlfunc. Обратите внимание, что правило для совпадения нулевой длины изменены несколько, в этом содержании слева "\ G" не считается, когда определение длины матча. Таким образом, следующее не будет соответствовать навсегда:

$str = 'ABC';
pos($str) = 1;
while (/.\G/g) {
    print $&;
}

Answer 5

Результат конструкции, подобной

$line=~ /(HD)/g

это список. Используйте while для перехода по хитам.