CODEWITHSUNDEEP
arraysperlhash
genesi5
genesi5

Reputation: 453

Perl, create hash of hashes tree from array of hashes

So, I have next array of hashes: 

my @arr = (
  #subways, "0" - superroot
  {id => "1",     parent_id => "0",     name => "subway 1"},
  #lines
  {id => "12642", parent_id => "1",     name => "no category"},
  {id => "12645", parent_id => "1",     name => "line 1"},
  #cars
  {id => "12646", parent_id => "1",     name => "carriage 1"},
  {id => "12646", parent_id => "12645", name => "carriage 1"},
  {id => "12647", parent_id => "1",     name => "carriage 2"},
  {id => "12647", parent_id => "12645", name => "carriage 2"},
  {id => "12679", parent_id => "1",     name => "separate cars"},
  {id => "12679", parent_id => "12642", name => "separate cars"},
  {id => "12643", parent_id => "1",     name => "ungrouped"},
  {id => "12643", parent_id => "12642", name => "ungrouped"}
);

and I heed to make a tree of them like:

subway->line->carriage

By the way, here's a problem. As you see - here's a "1" in doubling carriages, but I need line as parent_id. Is there a way to do this?

Upvotes: 0

Views: 423

Answers (2)

ikegami
ikegami

Reputation: 386371

use strict;
use warnings qw( all );
use feature qw( current_sub say );

my @rows = (
   #subways, "0" - superroot
   {id => "1",     parent_id => "0",     name => "subway 1"},
   #lines
   {id => "12642", parent_id => "1",     name => "no category"},
   {id => "12645", parent_id => "1",     name => "line 1"},
   #cars
   {id => "12646", parent_id => "1",     name => "carriage 1"},
   {id => "12646", parent_id => "12645", name => "carriage 1"},
   {id => "12647", parent_id => "1",     name => "carriage 2"},
   {id => "12647", parent_id => "12645", name => "carriage 2"},
   {id => "12679", parent_id => "1",     name => "separate cars"},
   {id => "12679", parent_id => "12642", name => "separate cars"},
   {id => "12643", parent_id => "1",     name => "ungrouped"},
   {id => "12643", parent_id => "12642", name => "ungrouped"}
);

my $tree = { name => "[root]", children => [] };
{
   my %tree = ( 0 => $tree );

   for my $row (@rows) {
      my $node = $tree{ $row->{id} } //= { name => undef, children => [] };
      $node->{name} = $row->{name};

      my $parent_node = $tree{ $row->{parent_id} } //= { name => undef, children => [] };
      push @{ $parent_node->{children} }, $node;
   }
}

# Add depth to nodes.
# use a breadth-first search so that the depth of nodes
# at multiple depths are set to the node's deepest depth.
{
   my @todo = ( [ $tree, 0 ] );
   while (@todo) {
      my ($node, $depth) = @{ shift(@todo) };
      $node->{depth} = $depth;

      ++$depth;
      push @todo, map { [ $_, $depth ] } @{ $node->{children} };
   }
}

# Trim shortcuts to deeper nodes.
{
   my @todo = $tree;
   while (@todo) {
      my $node = shift(@todo);
      my $depth = delete($node->{depth}) + 1;
      @{ $node->{children} } = grep { $_->{depth} == $depth } @{ $node->{children} };
      push @todo, @{ $node->{children} };
   }
}

# Display tree
my $visitor = sub {
   my ($node, $depth) = @_;
   say "  " x $depth, $node->{name};
   __SUB__->($_, $depth+1) for @{ $node->{children} };
};

$visitor->($_, 0) for @$tree;

Output:

subway 1
  no category
    separate cars
    ungrouped
  line 1
    carriage 1
    carriage 2

Upvotes: 3

Borodin
Borodin

Reputation: 126742

Update

My apologies. I missed your final paragraph that explained how an item may have a spurious parent "1" in addition to the real value. I've added some code to sanitise the original data and create a map %parent of every node to its true parent before building the graph

use strict;
use warnings 'all';

use Graph::Directed;

my @arr = (

    #subways, "0" - superroot
    { id => "1", parent_id => "0", name => "subway 1" },

    #lines
    { id => "12642", parent_id => "1", name => "no category" },
    { id => "12645", parent_id => "1", name => "line 1" },

    #cars
    { id => "12646", parent_id => "1",     name => "carriage 1" },
    { id => "12646", parent_id => "12645", name => "carriage 1" },
    { id => "12647", parent_id => "1",     name => "carriage 2" },
    { id => "12647", parent_id => "12645", name => "carriage 2" },
    { id => "12679", parent_id => "1",     name => "separate cars" },
    { id => "12679", parent_id => "12642", name => "separate cars" },
    { id => "12643", parent_id => "1",     name => "ungrouped" },
    { id => "12643", parent_id => "12642", name => "ungrouped" }
);

# Sanitise data to remove "1" parents
#
my %parent;

for my $node ( @arr ) {
    my ($id, $parent_id) = @{$node}{qw/ id parent_id /};
    next unless $parent_id;
    $parent{$id} = $parent_id unless $parent{$id} and $parent{$id} ne 1;
}

# Build the graph
#
my $tree = Graph::Directed->new;

for my $node ( keys %parent ) {
    $tree->add_edge( $parent{$node} => $node );
}

# Display the data
#
my %names = map { @{$_}{qw/ id name /} } @arr;

print_tree($tree, $_) for $tree->predecessorless_vertices;

sub print_tree {
    my ($tree, $root, $indent) = @_;
    $indent //= 0;

    printf "%s%s\n",  '    ' x $indent, $names{$root};

    print_tree($tree, $_, $indent + 1) for $tree->successors($root);
}

output

subway 1
    line 1
        carriage 1
        carriage 2
    no category
        separate cars
        ungrouped


Original answer

I suggest that you make use of the Graph module. A tree is a directed graph, and all you need to do is create a graph, add the connections ("edges") and interrogate the result

This program does exactly that. I have written a print_tree subroutine which displays the tree in indented lines from a given starting point. A call to predecessorless_vertices finds all the roots of the tree: nodes which no other node connects to. In this case there is just one root, as there should be

use strict;
use warnings 'all';

use Graph::Directed;

my @arr = (

    #subways, "0" - superroot
    { id => "1", parent_id => "0", name => "subway 1" },

    #lines
    { id => "12642", parent_id => "1", name => "no category" },
    { id => "12645", parent_id => "1", name => "line 1" },

    #cars
    { id => "12646", parent_id => "1",     name => "carriage 1" },
    { id => "12646", parent_id => "12645", name => "carriage 1" },
    { id => "12647", parent_id => "1",     name => "carriage 2" },
    { id => "12647", parent_id => "12645", name => "carriage 2" },
    { id => "12679", parent_id => "1",     name => "separate cars" },
    { id => "12679", parent_id => "12642", name => "separate cars" },
    { id => "12643", parent_id => "1",     name => "ungrouped" },
    { id => "12643", parent_id => "12642", name => "ungrouped" }
);

# Build the graph
#
my $tree = Graph::Directed->new;

for my $node ( @arr ) {
    $tree->add_edge( @{$node}{qw/ parent_id id /} ) if $node->{parent_id};
}

# Display the structure
#
my %names = map { @{$_}{qw/ id name /} } @arr;

print_tree($tree, $_) for $tree->predecessorless_vertices;

sub print_tree {
    my ($tree, $root, $indent) = @_;
    $indent //= 0;

    printf "%s%s\n",  '    ' x $indent, $names{$root};

    print_tree($tree, $_, $indent + 1) for $tree->successors($root);
}

output

subway 1
    no category
        ungrouped
        separate cars
    carriage 2
    carriage 1
    separate cars
    ungrouped
    line 1
        carriage 2
        carriage 1

Upvotes: 1

Related Questions