Более быстрый способ agrep? Быстро найти несоответствие каждого персонажа

Question

Я ищу самый быстрый способ найти каждое несоответствие каждого символа в большом файле. Если у меня есть это:

AAAA
AAAB
AABA
BBBB
CCCC

Я хотел бы получить что-то вроде этого:

AAAA - AAAB AABA
AAAB - AAAA
AABA - AAAA
BBBB
CCCC

В настоящее время я использую agrep, но мой файл имеет миллионы строк и работает очень медленно. Каждое слово находится на отдельной строке, и все они имеют одинаковое количество символов. Я ожидаю, что есть что-то элегантное, что я не смог найти. благодарю вас

Изменить: слова состоят всего из 5 символов, A T C G или N, и они имеют длину менее 100 символов. Все это должно уместиться в памяти (<5 ГБ). В каждой строке есть одно слово, и я хочу сравнить его со всеми другими словами.

Edit2: пример был неправильным. Это исправлено.

Answer 1

Если вы ищете слова, которые имеют разницу только в один символ, есть несколько хитростей, которые вы можете использовать. Во-первых, чтобы сравнить два слова и посчитать количество символов, вы используете это:

( $word1 ^ $word2 ) =~ tr/\0//c

Это делает строковое исключение или для двух слов; где символы одинаковы, в результате будет "\0"; где они не одинаковы, в результате будет не "\0". tr в режиме подсчета дополнений считает различия.

Во-вторых, отметив, что либо первая половина, либо последняя половина слова должны точно совпадать, разбейте слова на хеш по их первой и последней половинкам, сократив количество других слов, с которыми нужно проверять данное слово.

Этот подход должен только в два или три раза увеличить память всех строк (плюс немного накладных расходов); это может быть уменьшено в один-два раза памяти, нажав \$word и используя $$_ в карте grep и sort $$_, @match в выводе за счет некоторой скорости.

Если все слова имеют одинаковую длину, верхний уровень хеша может быть удален, и два разных хеша используются для начала и окончания слов.

use strict;
use warnings;
use autodie;
my %strings;

my $filename = shift or die "no filename provided\n";
open my $fh, '<', $filename;
while (my $word = readline $fh) {
    chomp $word;
    push @{ $strings{ 'b' . length $word }{ substr($word, 0, length($word)/2)} }, $word;
    push @{ $strings{ 'e' . length $word }{ substr($word, length($word)/2)} }, $word;
}
seek $fh, 0, 0;
while (my $word = readline $fh) {
    chomp $word;
    my @match = grep 1 == ($word ^ $_) =~ tr/\0//c, @{ $strings{ 'b' . length $word }{ substr($word, 0, length($word)/2) } }, @{ $strings{ 'e' . length $word }{ substr($word, length($word)/2) } };
    if (@match) {
        print "$word - " . join( ' ', sort @match ) . "\n";
    }
    else {
        print "$word\n";
    }
}

Обратите внимание, что это ищет только замены, а не вставки, удаления или транспозиции.

Answer 2

Это требует большого объема памяти, но следующее может выполнить вашу задачу в два этапа:

#!/usr/bin/env perl

use strict;
use warnings;

use Fcntl qw(:seek);

my $fh = \*DATA;

my $startpos = tell $fh;

my %group;

while (<$fh>) {
    chomp;

    my $word = $_;

    for my $i ( 0 .. length($word) - 1 ) {
        substr my $star = $word, $i, 1, "\0";
        push @{ $group{$star} }, \$word;
    }
}

seek $fh, $startpos, SEEK_SET;

while (<$fh>) {
    chomp;

    my %uniq;

    my $word = $_;

    for my $i ( 0 .. length($word) - 1 ) {
        substr my $star = $word, $i, 1, "\0";
        $uniq{$_}++ for map $$_, @{ $group{$star} };
    }

    delete $uniq{$word};

    print "$word - ", join(' ', sort keys %uniq), "\n";
}

__END__
AAAA
AAAB
AABA
BBBB
CCCC

Выходы:

AAAA - AAAB AABA
AAAB - AAAA
AABA - AAAA
BBBB - 
CCCC -