Как подсчитать количество паттернов, используя переменные в операторе tr///?

$hash{$nt} = eval "\$orf =~ tr/\Q$nt\E//"

должен сделать работу. Хотя, возможно, это не самое эффективное решение.

В "ATGCTAGCTAGCATAGAGCTAGCTA" нет экземпляров "$", "n" или "t", поэтому tr правильно возвращает ноль.

Если вы хотите создать оператор tr///, вам нужно будет проанализировать и скомпилировать его.

my %counts;
for my $nt (@atgc) {
   $counts{$nt} = eval "\$orf =~ tr/\Q$nt\E//";
}

Но я бы не стал использовать tr///.

my %atgc = map { $_ => 1 } @atgc;
my %counts;
++$counts{$nt} for grep $atgc{$_}, split //, $orf;

К сожалению, Perl не будет интерполировать переменную в список поиска для tr///. Вместо этого вам придется использовать регулярное выражение:

use strict;
use warnings;

my $orf = "ATGCTAGCTAGCATAGAGCTAGCTA";
my @atgc = qw(A T G C);
my %count;

$count{$1}++ while $orf =~ /([@atgc])/g;

printf "%s => %d\n", $_, $count{$_} for @atgc;

вывод

A => 8
T => 6
G => 6
C => 5

Осторожно

Это не является, как может показаться, общим решением для сопоставления любой из массива строк. Происходит следующее: @atcg интерполируется в регулярное выражение, как если бы оно было в строке в двойных кавычках. Это означает, что Perl будет использовать встроенную переменную $" (по умолчанию установленную на один пробел), чтобы преобразовать ее в строку, эквивалентную join $", @atgc.

Итак, код на самом деле выглядит так

$count{$1}++ while $orf =~ /([A T G C])/g;

который будет соответствовать пробелам, а также буквам, и может полностью прерваться, если @atgc содержит что-то особенное внутри класса символов регулярного выражения, например ^, ] или -.

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

Счетчик для каждого символа ASCII можно безопасно записать как

$count{$1}++ while $orf =~ /(.)/sg;

а нежелательную информацию в хеше %count можно просто игнорировать.

Вы можете использовать s///g:

#!/usr/bin/env perl

use strict; use warnings;

my $orf = "ATGCTAGCTAGCATAGAGCTAGCTA";
my @atgc = qw(A T G C);

my %hash = map {$_ => $orf =~ s/$_/$_/g } @atgc;

Выход:

---
A: 8
C: 5
G: 6
T: 6

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

#!/usr/bin/env perl

use strict; use warnings;

my $orf = "ATGCTAGCTAGCATAGAGCTAGCTA";
my %atgc = map { $_ => undef } qw(A T G C);

use YAML;
print Dump count(\$orf, \%atgc);

sub count {
    my $src_ref = shift;
    my $lookup = shift;

    my %count;

    open my $src, '<', $src_ref or die $!;
    {
        local $/ = \1;
        exists $lookup->{$_} and $count{ $_ } += 1 while <$src>;
    }
    close $src;

    return \%count;
}

Для этого вам не нужны регулярные выражения и т. д., вам просто нужно пройти строку:

my $orf = "ATGCTAGCTAGCATAGAGCTAGCTA";
my %nt;

$nt{$_}++ foreach (split('', $orf));

Сделайте компилятор шаблонов.

sub make_counter {
  my @sequences = @_;

  my $pattern = "(?:" . join("|", map quotemeta, @sequences) . ")";

  my $compiled = eval q<
    sub {
      local($_) = @_;
      my $n = () = /$pattern/g;
    }
  >;

  if (defined $compiled) {
    return $compiled;
  }
  else {
    die "$0: internal: counter compilation failed:\n$@\n";
  }
}

С помощью quotemeta мы заставляем все символы в последовательности соответствовать только самим себе без специального значения. Раздел 4 часто задаваемых вопросов по Perl описывает этот странный бит для подсчета совпадений:

Другая версия использует глобальное совпадение в контексте списка, а затем присваивает результат скаляру, производя подсчет количества совпадений.

$count = () = $string =~ /-\d+/g;

Обратите внимание, что он допускает мусор в вашей последовательности. Например, подсчитайте нуклеотиды с помощью

my @nucleotides = qw/ G A T C /;

my $numnuc = make_counter @nucleotides;
print $numnuc->("xGxAxTxxxxTyA1C2A"), "\n";

Выход:

7

Подсчитайте кодоны с

my @codons = qw(
  TTT TCT TAT TGT TTC TCC TAC TGC TTA TCA TAA TGA
  TTG TCG TAG TGG CTT CCT CAT CGT CTC CCC CAC CGC
  CTA CCA CAA CGA CTG CCG CAG CGG ATT ACT AAT AGT
  ATC ACC AAC AGC ATA ACA AAA AGA ATG ACG AAG AGG
  GTT GCT GAT GGT GTC GCC GAC GGC GTA GCA GAA GGA
  GTG GCG GAG GGG
);

my $numcod = make_counter @codons;
print $numcod->("GAG-GGG!AGG,TAT#TTT");

Обратите внимание, что любой мусор, если он присутствует, должен располагаться между последовательностями кодонов.

Выход:

5