in reply to Counting elements in array of cases

Preserves order of both targetL and origin.

#!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11106779 use warnings; use List::Util qw( uniq ); my @AoH = ( { count => 1, origin => "AMG", targetL => "foisonnement" }, { count => 1, origin => "IDBR", targetL => "foisonnement" }, { count => 1, origin => "IWWF", targetL => "gonfler" }, { count => 1, origin => "IWWF", targetL => "due" }, { count => 1, origin => "IWWF", targetL => "due" }, ); my %seen; my @AoHfinal = grep { if( my $prev = $seen{$_->{targetL}} ) { $prev->{count} += $_->{count}; $prev->{origin} = join ' ', uniq split(' ', $prev->{origin}), $_-> +{origin}; 0 # skip duplicate } else { $seen{$_->{targetL}} = $_; } } @AoH; use Data::Dump 'dd'; dd @AoHfinal;

Outputs:

( { count => 2, origin => "AMG IDBR", targetL => "foisonnement" }, { count => 1, origin => "IWWF", targetL => "gonfler" }, { count => 2, origin => "IWWF", targetL => "due" }, )

Replies are listed 'Best First'.
Re^2: Counting elements in array of cases
by LanX (Saint) on Sep 27, 2019 at 15:37 UTC
    Interesting approach! ++ :)

    Allow me some side notes:

    1. it's destructive.

    Copying the first hash with

    $seen{$_->{targetL}} = {%$_};

    should fix it.(can't test)

    2. Also are the repeated splits not really efficient... Not sure how best to change that.

    3. For better clarity I'd rather use a map and not a grep.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery FootballPerl is like chess, only without the dice

      It's destructive => There was no requirement to not do that. I'll resort to my old saying "If it passes all the test cases, it's correct :)"

      Repeated splits => Just concatenate as we go, and fix up right before the end. Is it really faster? I don't know and I don't care :)

      Like so:

      #!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11106779 use warnings; use List::Util qw( uniq ); my @AoH = ( { count => 1, origin => "AMG", targetL => "foisonnement" }, { count => 1, origin => "IDBR", targetL => "foisonnement" }, { count => 1, origin => "IWWF", targetL => "gonfler" }, { count => 1, origin => "IWWF", targetL => "due" }, { count => 1, origin => "IWWF", targetL => "due" }, ); my %seen; my @AoHfinal = grep { $_->{origin} = join ' ', uniq split ' ', $_->{or +igin} } map { if( my $prev = $seen{$_->{targetL}} ) { $prev->{count} += $_->{count}; $prev->{origin} .= ' ' . $_->{origin}; () # skip duplicate } else { $seen{$_->{targetL}} = { %$_ }; } } @AoH; use Data::Dump 'dd'; dd @AoHfinal;

        Using a for instead of that grep

        #!/usr/bin/perl use strict; # https://perlmonks.org/?node_id=11106779 use warnings; use List::Util qw( uniq ); my @AoH = ( { count => 1, origin => "AMG", targetL => "foisonnement" }, { count => 1, origin => "IDBR", targetL => "foisonnement" }, { count => 1, origin => "IWWF", targetL => "gonfler" }, { count => 1, origin => "IWWF", targetL => "due" }, { count => 1, origin => "IWWF", targetL => "due" }, ); my %seen; $_->{origin} = join ' ', uniq split ' ', $_->{origin} for my @AoHfinal + = map { if( my $prev = $seen{$_->{targetL}} ) { $prev->{count} += $_->{count}; $prev->{origin} .= ' ' . $_->{origin}; () # skip duplicate } else { $seen{$_->{targetL}} = { %$_ }; # copy hash so not destructive } } @AoH; use Data::Dump 'dd'; dd @AoHfinal;
        Here, I tried to change tybalt89's code by including one more hash deeper instead of uniq:
        #!/usr/bin/perl # https://perlmonks.org/?node_id=11106779 use strict; use warnings; use Data::Dumper; my @AoH = ( { count => 1, origin => "AMG", targetL => "foisonnement" }, { count => 1, origin => "IDBR", targetL => "foisonnement" }, { count => 1, origin => "AMG", targetL => "foisonnement" }, { count => 1, origin => "IWWF", targetL => "gonfler" }, { count => 1, origin => "IWWF", targetL => "due" }, { count => 1, origin => "IWWF", targetL => "due" }, ); my %seen; my @AoHfinal = # map { delete $_->{origins}; $_ } map { if( my $prev = $seen{$_->{targetL}} ) { $prev->{count} += $_->{count}; if( not exists $prev->{origins}{ $_->{origin} } ){ $prev->{origin} .= ' ' . $_->{origin}; $prev->{origins}{ $_->{origin} } ++; } () # skip duplicate } else { $_->{origins}{ $_->{origin} } ++; $seen{$_->{targetL}} = { %$_ }; } } @AoH; print Dumper( \@AoHfinal );
        OUTPUT:
        $VAR1 = [ { 'count' => 3, 'origin' => 'AMG IDBR', 'targetL' => 'foisonnement', 'origins' => { 'IDBR' => 1, 'AMG' => 1 } }, { 'count' => 1, 'targetL' => 'gonfler', 'origin' => 'IWWF', 'origins' => { 'IWWF' => 1 } }, { 'count' => 2, 'origins' => { 'IWWF' => 1 }, 'origin' => 'IWWF', 'targetL' => 'due' } ];
        > There was no requirement to not do that.

        Sure, as so often requirements are ambiguous and interpretations vary, that's why I added side notes.

        Anyway I like the approach a lot, this pattern is not too often applied.

        But I was probably also overmotivated because I understood your code... ;)

        Cheers Rolf
        (addicted to the Perl Programming Language :)
        Wikisyntax for the Monastery FootballPerl is like chess, only without the dice

      my take on it...
      #!/usr/bin/perl -w # AoH_map.pl --- Perlmonks: Counting elements in array of cases # Link: https://perlmonks.org/?node_id=11106779 # Author: <LanX> # Base: <tybalt89> https://perlmonks.org/?node_id=11106792 # Created: 28 Sep 2019 # Version: 0.03 use warnings; use strict; use Test::More; sub transform { my %prev; my %origin; return map { my $target = $_->{targetL}; my $origin = $_->{origin}; if ( my $prev = $prev{$target} ) { $prev->{count} += $_->{count}; $prev->{origin} .= " $origin" unless $origin{$target}{$origin}++; # + ++ FIXED () # skip duplicate } else { $origin{$target}{$origin} = 1; $prev{$target} = { %$_ }; # return first (clone) } } @_; } # ---------- tests is_deeply ( [ transform( {'targetL' => 'foisonnement', 'origin' => 'AMG', 'count' => '1 +'}, {'targetL' => 'foisonnement', 'origin' => 'IDBR', 'count' => ' +1'}, {'targetL' => 'gonfler', 'origin' => 'IWWF', 'count' => '1'}, {'targetL' => 'due', 'origin' => 'IWWF', 'count' => '1' }, {'targetL' => 'due', 'origin' => 'IWWF', 'count' => '1' }, ) ], [ {'targetL' => 'foisonnement','origin' => 'AMG IDBR','count'=>' +2'}, {'targetL' => 'gonfler','origin' => 'IWWF','count' => '1'}, {'targetL' => 'due','origin' => 'IWWF','count' => '2'}, ] ); is_deeply ( [ transform( {'targetL' => 'foisonnement', 'origin' => 'AMG', 'count' => '1 +'}, {'targetL' => 'foisonnement', 'origin' => 'IDBR', 'count' => ' +1'}, {'targetL' => 'foisonnement', 'origin' => 'AMG', 'count' => '1 +'}, {'targetL' => 'foisonnement', 'origin' => 'IDBR', 'count' => ' +1'}, ) ], [ {'targetL' => 'foisonnement','origin' => 'AMG IDBR','count'=>' +4'}, ] ); done_testing;

      C:/Perl_524/bin\perl.exe d:/tmp/pm/AoH_map.pl ok 1 ok 2 1..2 Compilation finished at Sun Sep 29 00:44:35

      Cheers Rolf
      (addicted to the Perl Programming Language :)
      Wikisyntax for the Monastery FootballPerl is like chess, only without the dice

      update

      added missing ++ and testcase, see reply from rsFalse for details.

        This is similar approach to mine (Re^4: Counting elements in array of cases).

        But can you test it on:
        {'targetL' => 'foisonnement', 'origin' => 'AMG', 'count' => '1 +'}, {'targetL' => 'foisonnement', 'origin' => 'IDBR', 'count' => ' +1'}, {'targetL' => 'foisonnement', 'origin' => 'AMG', 'count' => '1 +'}, {'targetL' => 'foisonnement', 'origin' => 'IDBR', 'count' => ' +1'},