replicant4 has asked for the wisdom of the Perl Monks concerning the following question:

Hi all. I posted yesterday a question under the title pairwie comparisons. This solution script does answer my question, but I need a minor modiifcation if it is possible. The script that works is :
use strict;
use warnings;

use Algorithm::Loops qw( MapCar );

my @site1 = qw(
   AATKKM
   123456
);

my @site2 = qw(
   GGGGGG
   !@#$%^
);

my $site1;
my $site2;

my @pairs;
my %counts;

foreach $site1 (@site1) {
   my @site1_parts = split(//, $site1);

   foreach $site2 (@site2) {
      my @site2_parts = split(//, $site2);

      MapCar { $counts{$_[0].$_[1]}++ }
         \@site1_parts, \@site2_parts;
   }
}

print($_, ': ', $counts{$_}, $/) foreach (sort keys %counts);

__END__
output
======
1!: 1
1G: 1
2@: 1
2G: 1
3#: 1
3G: 1
4$: 1
4G: 1
5%: 1
5G: 1
6G: 1
6^: 1
A!: 1
A@: 1
AG: 2
K$: 1
K%: 1
KG: 2
MG: 1
M^: 1
T#: 1

[download]
What I need is that every time that compare one $site from @array1, I need to reset the counters to 0 if it is possible. Then I need to add the values of the counters. Is this possible? Thanks in advance for anyone's help
  • Comment on a bit more help with pairwise comparisons between strings in arrays.
  • Download Code

Replies are listed 'Best First'.
Re: a bit more help with pairwise comparisons between strings in arrays.
by ikegami (Patriarch) on Oct 20, 2004 at 18:28 UTC

    Just move the my %counts and the print of %counts into into the first foreach:

    use strict;
use warnings;

my @site1 = qw(
   AATKKM
   AKTKKM
);

my @site2 = qw(
   GGGGGG
   HHHHHH
);

my $site1;
my $site2;

foreach $site1 (@site1) {
   my @site1_parts = split(//, $site1);

   my %counts;

   foreach $site2 (@site2) {
      my @site2_parts = split(//, $site2);

      my $i = @site1_parts;
      $counts{$site1_parts[$i].$site2_parts[$i]}++ while ($i--);
   }

   print($_, ': ', $counts{$_}, $/) foreach (sort keys %counts);
   print($/);
}

__END__
output
======
AG: 2
AH: 2
KG: 2
KH: 2
MG: 1
MH: 1
TG: 1
TH: 1

AG: 1
AH: 1
KG: 3
KH: 3
MG: 1
MH: 1
TG: 1
TH: 1

    [download]

    I got rid of MapCar since it wasn't needed. (Yeah, I know I'm the one who introduced MapCar in the first place.) I also switched to data that better illustrates the results.

    If you don't want to discard the previous counts before the loops is over, you can use an AoH:

    use strict;
use warnings;

my @site1 = qw(
   AATKKM
   AKTKKM
);

my @site2 = qw(
   GGGGGG
   HHHHHH
);

my $site1;
my $site2;

my @count_collection;

foreach $site1 (@site1) {
   my @site1_parts = split(//, $site1);

   my %counts;

   foreach $site2 (@site2) {
      my @site2_parts = split(//, $site2);

      my $i = @site1_parts;
      $counts{$site1_parts[$i].$site2_parts[$i]}++ while ($i--);
   }

   push(@count_collection, \%counts);
}

foreach (@count_collection) {
   my $counts = $_;
   print($_, ': ', $counts->{$_}, $/) foreach (sort keys %$counts);
   print($/);
}

__END__
output
======
AG: 2
AH: 2
KG: 2
KH: 2
MG: 1
MH: 1
TG: 1
TH: 1

AG: 1
AH: 1
KG: 3
KH: 3
MG: 1
MH: 1
TG: 1
TH: 1

    [download]
[reply]
[d/l]
[select]
      Thanks ikegami. One final question, and I hope I am not bothering you too much. The way of the comparisons does not matter. Concerning the counts, count AG=countGA, so is it possible to have that as well, meaning that if AG, GA appears while comparing, to have count AG+2 instead of having countAG+1 and countGA+1 ? Once again you have been more than hekpfull, thanks a lot.
[reply]

        You really should try to answer your questions before asking them.

        The simple way is to sort the two letters before concatenating them and using the result as the index:

        Add
        sub get_index { $_[0] lt $_[1] ? ($_[0].$_[1]) : ($_[1].$_[0]) }
        and replace
        $counts{$site1_parts[$i].$site2_parts[$i]}++ while ($i--);
        with
        $counts{get_index($site1_parts[$i], $site2_parts[$i])}++ while ($i--);

        my @site1 = qw( AGTTTT );
        my @site2 = qw( GAKKHT );
        gives
        AG: 2, HT: 1, KT: 2, TT: 1

[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom