使用 Perl 分组：找到更快的递归解决方案

Question

下面的 Perl 代码可以工作，但即使有相当多的计算机资源，它也不能很好地扩展。我希望有人可以帮助我找到更有效的代码，例如用迭代替换递归，如果这是问题的话。

我的数据结构如下所示： 我的 %REV_ALIGN;
$REV_ALIGN{$dna}{$rna} = ();

任何 dna 密钥都可能有多个 rna 子密钥。同一个 rna 子键可能与多个不同的 dna 键一起出现。目的是根据共享的 dna 序列元素对 rna（转录本）进行分组。例如，如果 dnaA 有 RNA1、RNA8、RNA9 和 RNA4，而 dnaB 有 RNA11、RNA4 和 RNA99，那么我们将所有这些转录本组合在一起（RNA1、RNA9、RNA4、RNA11、RNA99）并继续尝试通过选择其他 dna 添加到组中。我对这个问题的递归解决方案有效，但在使用来自全基因组的数据进行转录组比对时不能很好地扩展。

所以我的问题是：有什么更有效的解决方案来解决这个问题？非常感谢你

my @groups;

while ( my $x =()= keys %REV_ALIGN )
{
    my @DNA = keys %REV_ALIGN;
    my $dna = shift @DNA;
    # the corresponding list of rna
    my @RNA = keys %{$REV_ALIGN{$dna}};
    delete $REV_ALIGN{$dna};

    if ( $x == 1 )
    {
        push @groups, \@RNA;
        last;
    }

    my $ref = group_transcripts ( \@RNA, \%REV_ALIGN );
    push @groups, $ref;
}


sub group_transcripts
{
    my $tran_ref = shift;
    my $align_ref = shift;
    my @RNA_A = @$tran_ref;
    my %RNA;
    # create a null hash with seed list of transcripts
    @RNA{@RNA_A} = ();
    # get a list of all remaining dna sequences in the alignment
    my @DNA = keys %{$align_ref};
    my %count;
    # select a different list of transcripts
    for my $dna ( @DNA )
    {
        next unless exists $align_ref->{$dna};
        my @RNA_B = keys %{$align_ref->{$dna}};
        # check to see two list share and transcripts
        for my $element ( @RNA_A, @RNA_B )
        {
            $count{$element}++;
        }
        for my $rna_a ( keys %count )
        {
            # if they do, add any new transcripts to the current group
            if ( $count{$rna_a} == 2 )
            {
                for my $rna_b ( @RNA_B )
                {
                    push @RNA_A, $rna_b if $count{$rna_b} == 1;
                }
                delete $align_ref->{$dna};
                delete $count{$_} foreach keys %count;
                # recurse to try and continue adding to list
                @_ = ( \@RNA_A, $align_ref );
                goto &group_transcripts;
            }
        }
        delete $count{$_} foreach keys %count;
    }
   # if no more transcripts can be added, return a reference to the group
    return \@RNA_A;
}

Answer 1

你有一个嵌套四层的循环。这是一个非常安全的赌注，这就是您的代码扩展性差的原因。

如果我正确理解您要完成的工作，请输入

my %REV_ALIGN = (
   "DNA1" => { map { $_ => undef } "RNA1", "RNA2" }, # \ Linked by RNA1     \
   "DNA2" => { map { $_ => undef } "RNA1", "RNA3" }, # /  \ Linked by RNA3   > Group
   "DNA3" => { map { $_ => undef } "RNA3", "RNA4" }, #    /                 /

   "DNA4" => { map { $_ => undef } "RNA5", "RNA6" }, # \ Linked by RNA5     \  Group
   "DNA5" => { map { $_ => undef } "RNA5", "RNA7" }, # /                    /

   "DNA6" => { map { $_ => undef } "RNA8" },         #                      >  Group
);

应该会导致

my @groups = (
   [
      dna => [ "DNA1", "DNA2", "DNA3" ],
      rna => [ "RNA1", "RNA2", "RNA3", "RNA4" ],
   ],
   [
      dna => [ "DNA4", "DNA5" ],
      rna => [ "RNA5", "RNA6", "RNA7" ],
   ],
   [
      dna => [ "DNA6" ],
      rna => [ "RNA8" ],
   ],
);

如果是这样，您可以使用以下内容：

use strict;
use warnings;

use Graph::Undirected qw( );

my %REV_ALIGN = (
   "DNA1" => { map { $_ => undef } "RNA1", "RNA2" },
   "DNA2" => { map { $_ => undef } "RNA1", "RNA3" },
   "DNA3" => { map { $_ => undef } "RNA3", "RNA4" },
   "DNA4" => { map { $_ => undef } "RNA5", "RNA6" },
   "DNA5" => { map { $_ => undef } "RNA5", "RNA7" },
   "DNA6" => { map { $_ => undef } "RNA8" },
);

my $g = Graph::Undirected->new();
for my $dna (keys(%REV_ALIGN)) {
   for my $rna (keys(%{ $REV_ALIGN{$dna} })) {
      $g->add_edge("dna:$dna", "rna:$rna");
   }
}

my @groups;
for my $raw_group ($g->connected_components()) {
   my %group = ( dna => [], rna => [] );
   for (@$raw_group) {
      my ($type, $val) = split(/:/, $_, 2);
      push @{ $group{$type} }, $val;
   }

   push @groups, \%group;
}

use Data::Dumper qw( Dumper );
print(Dumper(\@groups));

如果您只需要 RNA，最后部分简化为以下内容：

my @groups;
for my $raw_group ($g->connected_components()) {
   my @group;
   for (@$raw_group) {
      my ($type, $val) = split(/:/, $_, 2);
      push @group, $val if $type eq 'rna';
   }

   push @groups, \@group;
}