in reply to Re: Counting elements in array of cases
in thread Counting elements in array of cases

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

Replies are listed 'Best First'.
Re^3: Counting elements in array of cases
by tybalt89 (Monsignor) on Sep 27, 2019 at 17:13 UTC

    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

Re^3: Counting elements in array of cases (updated)
by LanX (Saint) on Sep 28, 2019 at 13:23 UTC
    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'},
        Yeah thanks, I even see the bug without testing.

        Ironically I first wrote unless ... ++ instinctively and then decided it's redundant. :)

        Will fix the code as soon as I get back to my PC

        update

        Fixed! :)

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