http://qs321.pair.com?node_id=570458


in reply to Build tree data structure from DB (flat) data; function golf

Well I didn't convert the foreach to a map, but I did remove some of your repeated code (closures++), and got rid of some checks and the a tiernary.

One note, though, this is a destructive function. When I tested the deeper case, it did not work because the original data structure ($old_data) is destroyed during the building of the tree. This is kind of a gotcha. 

sub tree_data {
  my ( $old_data, $key_name, $next_group, @remaining_keys ) = @_;
  
  # guard against bad input and serve as recursion end case
  return $old_data unless defined $key_name;
  
  my @new_data;
  my $last_key = '';  # if this is initialized, you dont have to check
+ below
  my $build_box = []; # initalize this explicity (more self documentin
+g)
  
  # encapsulate code into inner sub
  # fortunately for us, all variables 
  # are closed over too :)
  my $push_new_data = sub {
      return unless $last_key;
      push @new_data, {
          $key_name   => $last_key,
          $next_group => tree_data( $build_box, @remaining_keys )
      };
      # re-init this 
      $build_box = [];
  };

  foreach ( @{ $old_data } ) {
    if ( $last_key ne $_->{ $key_name } ) {
      $push_new_data->();
    }
    $last_key = delete $_->{ $key_name };
    push @{ $build_box }, $_;
  }
  $push_new_data->();

  return \@new_data;
}

[download]

Here is a complete test script which compares against the old one. 

#!/usr/bin/perl

use strict;
use warnings;
use Storable 'dclone';
use Data::Dumper;
use Test::More no_plan => 1;

sub orig_tree_data {
  my ( $old_data, $key_name, $next_group, @remaining_keys ) = @_;
  my ( @new_data, $last_key, $build_box );

  foreach ( @{ $old_data } ) {
    if ( $last_key and ( $last_key ne $_->{ $key_name } ) ) {
      push @new_data, {
        $key_name   => $last_key,
        $next_group => ( @remaining_keys )
          ? tree_data( $build_box, @remaining_keys )
          : $build_box,
      };
      undef $build_box;
    }
    $last_key = delete $_->{ $key_name };
    push @{ $build_box }, $_;
  }
  push @new_data, {
    $key_name   => $last_key,
    $next_group => ( @remaining_keys )
      ? tree_data( $build_box, @remaining_keys )
      : $build_box,
  };

  return \@new_data;
}

sub tree_data {
  my ( $old_data, $key_name, $next_group, @remaining_keys ) = @_;
  
  # guard against bad input and serve as recursion end case
  return $old_data unless defined $key_name;
  
  my @new_data;
  my $last_key = '';  # if this is initialized, you dont have to check
+ below
  my $build_box = []; # initalize this explicity (more self documentin
+g)
  
  # encapsulate code into inner sub
  # fortunately for us, all variables 
  # are closed over too :)
  my $push_new_data = sub {
      return unless $last_key;
      push @new_data, {
          $key_name   => $last_key,
          $next_group => tree_data( $build_box, @remaining_keys )
      };
      # re-init this 
      $build_box = [];
  };

  foreach ( @{ $old_data } ) {
    if ( $last_key ne $_->{ $key_name } ) {
      $push_new_data->();
    }
    $last_key = delete $_->{ $key_name };
    push @{ $build_box }, $_;
  }
  $push_new_data->();

  return \@new_data;
}

my $input = [
  {
    'team'       => 'A-Team',
    'employee'   => 'Face',
    'work_day'   => '2006-08-28',
    'other_data' => '123456789',
  },
  {
    'team'       => 'A-Team',
    'employee'   => 'Murdock',
    'work_day'   => '2006-08-28',
    'other_data' => '123456789',
  },
  {
    'team'       => 'Military',
    'employee'   => 'Decker',
    'work_day'   => '2006-08-28',
    'other_data' => '123456789',
  },
];
my $input2 = dclone($input);
my $input3 = dclone($input);
my $input4 = dclone($input);

is_deeply(
    tree_data( $input, 'team', 'employees' ),
    orig_tree_data( $input2, 'team', 'employees' ),
    '... both the same');
    
is_deeply(
    tree_data($input3, 'team', 'employees', 'employee', 'work_days'),
    orig_tree_data($input4, 'team', 'employees', 'employee', 'work_day
+s'),    
    '... both the same again');

[download]

-stvn

Replies are listed 'Best First'.
Re^2: Build tree data structure from DB (flat) data; function golf
by gryphon (Abbot) on Aug 30, 2006 at 19:59 UTC

    Greetings stvn,

    This is awesome. Thanks! I need to reprogram my brain so I'll think to use closures more readily. Maybe I need to re-read HOP. You make a great point about this being a destructive function. I think it's easy to fix, though:

    $last_key = delete $_->{ $key_name };
push @{ $build_box }, $_;

    [download]

    ...becomes...

    push @{ $build_box }, $_;
$last_key = delete $build_box->[-1]{$key_name};

    [download]

    UPDATE: I'm a crazy idiot. This doesn't do what I claim it should do. Bad programmer. No cookie. All I'm doing is moving the reference. I need to deep copy instead.

    gryphon
    Whitepages.com Development Manager (WDDC)
    code('Perl') || die;

[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom