File Coverage

blib/lib/Tree/Family.pm

Criterion	Covered	Total	%
statement	301	306	98.3
branch	79	96	82.2
condition	27	45	60.0
subroutine	38	38	100.0
pod	10	12	83.3
total	455	497	91.5

=head1 NAME

Tree::Family - Represent and visualize a family tree.

=cut

=head1 SYNOPSIS

 use Tree::Family;

 my $tree = Tree::Family->new(filename => '/tmp/mytree.dmp');

 my $person = Tree::Family::Person->new(name => 'Fred');
 my $nother = Tree::Family::Person->new(name => 'Wilma');

 $person->spouse($nother);

 $tree->add_person($person);
 $tree->add_person($nother);

 for ($tree->people) {
     print $_->name;
 }

 my $dot_file = $tree->as_dot;

=head1 DESCRIPTION

Use this module to represent spousal and parental relationships
among a group of people, and generate a graphviz "dot"
file to visualize them.

=head1 FUNCTIONS

=cut

package Tree::Family;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1; # makes diffing easier
use warnings;
use strict;
use List::MoreUtils qw(first_index last_index uniq);
use Algorithm::Permute;
use Clone qw(clone);
use YAML::XS qw/Dump Load LoadFile/;

our $VERSION = '0.02';
our $urlBase = 'http://localhost/';
our $GraphHeader = <<'';
graph family {
edge [ style=solid ];
node [ shape=box style=bold, color="black", fontsize="18", fontname="Times-Roman" ];
ranksep=2.0

our $GraphFooter = <<'';
}

our $bottomInvisibleEdges = ''; # populated and used below.
our $topInvisibleEdges = ''; # populated and used below.

sub debug($) {
     # print STDERR "@_";
}

=head2 new

my $tree = Tree::Family->new(filename => '/tmp/foobarfamily.dmp');

=cut

sub new {
    my ($class,%args) = @_;
    my $filename = $args{filename} or die "missing filename";
    return bless {
        filename => $filename,
    }, $class;
}

sub _init {
    my $self = shift;
    return if exists($self->{people});
    # $self->{people} will be a hash from ids to T:F:Person objects
    if (-e $self->{filename} && -s $self->{filename}) {
        my $filename = $self->{filename};
        $self->{people} = LoadFile $filename;
    } else {
        $self->{people} = {};
    }
    $self->{people} = { map { $_ => $self->{people}{$_}->Toast } keys %{ $self->{people} } };
    die "error reading $self->{filename}, got (".ref($self->{people}).") error: [$!] [$@]" unless ref($self->{people}) eq 'HASH';
}

#
# Assign numeric generations
#
sub _set_generations {
    my $self = shift;
    my %args = @_;
    our $haveSet;
    return if !$args{force} && $haveSet;
    $haveSet = 1;
    Tree::Family::Person->_clear_generations;
    for my $person (values %{ $self->{people} }) {
        next if $person->generation;
        $person->_set_all_generations(100);
    }
}

=head2 write

Write the family tree to a file

$tree->write

=cut

sub write {
    my $self = shift;
    $self->_init;
    $self->_set_generations;
    Tree::Family::Person->_clear_all_partners;
    Tree::Family::Person->_set_all_partners;
    my $filename = $self->{filename};
    my $tmpfile = $filename."-tmp-".$$.time.(rand 1);
    my %write = map { $_ => $self->{people}{$_}->Freeze } keys %{ $self->{people} };
    open FP, ">$tmpfile" or die "Couldn't write to $tmpfile : $!";
    print FP Dump( \%write );
    close FP;
    rename $tmpfile, $filename or die "Couldn't rename $tmpfile to $filename : $!";
    return 1;
}

=head2 add_person

Add a person to the tree

$tree->add_person($joe);

$joe should be a Tree::Family::Person object.

=cut

sub add_person {
    my $self = shift;
    $self->_init;
    my $person = shift;
    $self->{people}{$person->get('id')} = $person;
}

=head2 delete_person

Delete a person

$tree->delete_person($joe)

=cut

sub delete_person {
    my $self = shift;
    $self->_init;
    my $person = shift;
    $person->dad(undef);
    $person->mom(undef);
    $person->spouse(undef);
    for ($person->partners) {
        $person->_delete_partner($_);
    }
    for ($person->kids) {
        $person->delete_kid($_);
    }
    delete $self->{people}->{$person->id};
    $person->_delete_self;
}

=head2 people

Get a list of all the people in the tree

=cut

sub people {
    my $self = shift;
    $self->_init;
    return values %{ $self->{people} };
}

=head2 find

Find a person, specifying keys and values to search for.

$tree->find(id => 'sam');

$tree->find(first_name => 'joe', last_name => 'dimaggio');

=cut

sub find {
    my ($class,%args) = @_;
    shift->_init;
    Tree::Family::Person->find(%args);
}

=head2 min_generation

The numeric smallest generation.

=cut

sub min_generation {
    my $self = shift;
    $self->_init;
    $self->_set_generations;
    Tree::Family::Person->min_generation;
}

=head2 max_generation

The numeric highest generation.

=cut

sub max_generation {
    my $self = shift;
    $self->_init;
    $self->_set_generations;
    Tree::Family::Person->max_generation;
}

=head2 write_dotfile

Write out a .dot file (graphviz format).

$tree->write("output.dot");

=cut

sub write_dotfile {
    my ($self,$filename) = @_;
    die "missing filename" unless $filename;
    my $tmpfile = $filename."-tmp-".$$.time.(rand 1);
    open FP, ">$tmpfile" or die "Couldn't write to $tmpfile : $!";
    print FP $self->as_dot;
    close FP or die "couldn't close FP : $!";
    rename $tmpfile, $filename or die "Couldn't rename $tmpfile to $filename : $!";
    return 1;
}

#
# _add_person_and_all_ascendants
#
# Add a person and all their ascendants to the .dot output
#
sub _add_person_and_all_ascendants {
    my ($class,$person,$person2subgraph,$people_written,$subgraph_written,$all_subgraphs,$person2subgraphpeople) = @_;
    my $output = '';
    die "no person id " if defined($person) && !defined($person->id);
    return $output if $people_written->{$person->id};
    debug "adding person and all ascendants for ".$person->first_name."\n";

    # Find the subgraph containing dad (and hence mom), and then call ourself
    # recursively for every person in that subgraph.
    my $people;
    $people = $person2subgraphpeople->{ $person->mom->id } if $person->mom;
    $people ||= $person2subgraphpeople->{ $person->dad->id } if $person->dad;
    if ($people && @$people) {
        debug "Found subgraph for parents of ".$person->first_name." : ".
            (join ',', map $_->first_name, @$people)."\n"
    } else {
        debug "No ascendants for ".$person->first_name."\n";
    }
    # annoying dot hacks to untangle the generation above us.
    if ($person->spouse() &&
            ($person->mom && $person->dad) &&
            ($person->spouse->mom && $person->spouse->dad)) {
        # TODO also for partners (not spouse?)
        my $parent_node = _kid_node($person->mom,$person->dad);
        my $edges;
        if (had_kids($person,$person->spouse)) {
            $edges = _kid_node($person,$person->spouse())." -- $parent_node [style=invis];\n";
        } else {
            $edges = $person->id." -- $parent_node [style=invis];\n";
            $edges .= $person->spouse()->id." -- $parent_node [style=invis];\n";
        }

        if ($person->mom->spouse() || $person->dad->spouse()) {
            $bottomInvisibleEdges .= $edges;
        } else {
            $topInvisibleEdges .= $edges;
        }
    }

    for (@{ $people || [] }) {
        $output .= $class->_add_person_and_all_ascendants($_,$person2subgraph,$people_written,$subgraph_written,$all_subgraphs,$person2subgraphpeople);
    }
    $output .= $class->_person_node($person)."\n";
    my $subgraph_index = $person2subgraph->{$person->id};
    $output .= $all_subgraphs->[$subgraph_index] unless $subgraph_written->{$subgraph_index};
    $subgraph_written->{$subgraph_index} = 1;
    $people_written->{$person->id} = 1;
    return $output;
}

=head2 as_dot

Return the text for a .dot graphviz file

print $tree->as_dot

=cut

sub as_dot {
    my $class = shift;
    debug "as dot called\n";
    $class->_init;
    my @people = sort {
        warn "generation for $a or $b not set" unless defined($a->get('generation')) && defined($b->get('generation'));
        $a->get('generation') <=> $b->get('generation') } $class->people;
    my $output;

    # Make subgraphs for people with partners/spouses
    my %person2subgraph;  # map from person id to the dot text
    my @all_subgraphs;
    my %generation_subgraphs;   # keys are generations, values are arrays of arrays of people who are in a subgraph.
    my %person2subgraphpeople; # map from person id to an array of people in the subgraph
    for my $person (@people) {
        next if $person2subgraph{$person->get('id')};
        my @together = $class->_partner_and_marriage_group($person);
        debug "doing subgraph for : ".(join ',', map $_->first_name, @together)."\n";
        next unless @together > 0;
        $person2subgraph{$_->get('id')} = scalar(@all_subgraphs) for @together;
        push @all_subgraphs, $class->_partner_subgraph(\@together);
        debug "best ordering : ".(join ',', map $_->first_name, @together)."\n";
        $person2subgraphpeople{$_->get('id')} = \@together for @together;
    }

    # People
    my %people_written; # keeps track of people who have been written
    my %subgraph_written; # ids of subgraphs that have been written
    my %people_by_generation;
    for (@people) {
        push @{ $people_by_generation{$_->get('generation')} }, $_;
    }
    # starting with the bottom-most generation, do depth-first traversals to add
    # all ascendants and their partner subgraphs.
    # This also builds $bottomInvisibleEdges.   If this isn't on the
    # bottom of the graph, dot segfaults.
    # maybe on the top?  TODO
    # if it isn't on the top, they're in the wrong place
    $bottomInvisibleEdges = '';
    for (sort {$b <=> $a } keys %people_by_generation) {
        my $this_generation = $people_by_generation{$_};
        next unless $this_generation;
        debug "adding generation $_\n";
        for my $person (@$this_generation) {
            debug "starting generation with person ".$person->first_name."\n";
            $output .= $class->_add_person_and_all_ascendants($person,\%person2subgraph,\%people_written,\%subgraph_written,\@all_subgraphs,\%person2subgraphpeople);
        }
    }
    die "unwritten subgraphs, should not happen" if grep {!$_} values %subgraph_written;

    # Parent edges
    for my $person (@people) {
        my $parent_key = join '_', map $_->get('id'), grep defined, ($person->dad,$person->mom);
        next unless $parent_key;
        $output .= "$parent_key -- ".$person->get('id')." // Parents of ".$person->get('id')."\n";
    }

    # Generations
    my $min_generation = $class->min_generation;
    my $max_generation = $class->max_generation;
    $output .= "/* generations : ".$min_generation." to ".$max_generation." */\n";
    my @generation_nodes;
    my $i = 0;
    for my $g ($min_generation .. $max_generation) {
        my $generation_node = "generation_".(++$i);
        push @generation_nodes, $generation_node;
        my @this = $class->find(generation => $g);
        my $which = $g==$min_generation ? 'source' : $g==$max_generation ? 'sink' : 'same';
        $output .= "{rank=$which; $generation_node ".
            (join ' ',map $_->get('id'), @this)."}\n";
    }
    # Now add an invisible edge between the first member of each generation.
    my $generation_edges;
    $generation_edges .= join "--", @generation_nodes;
    $generation_edges .= "[style=invis];\n";
    for (@generation_nodes) {
        $generation_edges .= qq{$_ [label="" style=invis];\n};
    }

    return join "\n",$GraphHeader,$topInvisibleEdges,$generation_edges,$output,$bottomInvisibleEdges,$GraphFooter;
}

# All people who are connected to a given person via marriage or partnership
# ...and all people connected to those people, etc.
sub _partner_and_marriage_group {
    my ($class, $person ) = @_;
    my @all = ($person);
    my @add_me = $person->partners_and_spouse;
    debug "partners and spouse for ".$person->id." : ".@add_me."\n";
    #debug (join ',',map $_->id, @add_me)."\n";
    while (@add_me) {
        push @all, @add_me;
        my @just_added = @add_me;
        @add_me = ();
        for (@just_added) {
            for my $p ($_->partners_and_spouse) {
                next if grep { $p eq $_ } @all;
                push @add_me, $p;
            }
        }
    }
    my %uniq = map { ( $_->get('id') => $_ ) } @all;
    return values %uniq;
}

#
# _remove_duplicates
#
# Given a list of pairs of people, return a list of
# unique unordered pairs.  e.g. given
#    ( [a,b], [b,a], [c,d] )
#    return ( [a,b], [c,d] )
# where a,b,c,d are person objects.
#
sub _remove_duplicates {
    my @edges = @_;
    my @ret;
    my %h;
    for my $e (@edges) {
        next if $h{$e->[0]->id,$e->[1]->id}++;
        next if $h{$e->[1]->id,$e->[0]->id}++;
        push @ret, $e;
    }
    return @ret;
}

#
# _distance
#
# a metric on a list of ordered pairs :
#
# The sum of the difference between the first and last positions of each
# unique element, e.g.
#
# ( [a,b], [b,c], [c,d] ) == a -- b  b -- c  c -- d
#                            0    1  2    3  4    5
# 0-0 (a) + 2-1 (b) + 4-3 (c) + 5-5 (d) == 2
#
# ( [a,b], [c,d], [b,c] ) == a -- b  c -- d  b -- c
#                            0    1  2    3  4    5
# 0-0 (a) + (4-2) b + (5-2) c + 3-3 (d) = 5
#
# a,b,c,d are Tree::Family::Person objects
#
sub _distance {
    my @edges = @_;
    my @flattenned = map @$_, @edges;
    my %seen;
    my $distance = 0;
    for my $m (@flattenned) {
        next if $seen{$m->id}++;
        my $first = first_index { $_->id eq $m->id } @flattenned;
        my $last =  last_index  { $_->id eq $m->id } @flattenned;
        $distance += ($last - $first);
    }
    return $distance;
}

#
#_are_married
#
#_are_married($joe,$sue)
#
#returns true iff $joe and $sue are married
#
sub _are_married {
    my ($a,$b) = @_;
    return ($a->spouse() && $b->spouse() && $a->spouse->id eq $b->id);
}

#
# return --- or -+- for two people depending on whether they
# are married or not.
#
sub _ascii_pair {
    my ($a,$b) = @_;
    if (_are_married($a,$b)) {
        return join '-+-', $a->id, $b->id;
    }
    return join '---', $a->id, $b->id;
}

#
# parameters : an array ref of pairs of people
# returns    : nothing, but puts 'em in a decent order, to minimize the
#              distance between elements of the pairs.
#
# e.g. given ( [d,c], [a,b], [b,c] )
# the best ordering would be one of
#            ( [a,b], [b,c], [c,d] )
#            ( [d,c], [c,b], [b,a] )
# since then they could appear like so:
#            a -- b -- c -- d
#
sub _find_best_ordering {
    my @pairs = @_;
    debug "-- finding best ordering of ".@pairs." marriages/partnerships\n";
    return @pairs unless @pairs > 1;
    my $min_distance;
    my @best = @pairs;
    my $i = Algorithm::Permute->new(\@pairs);
    my @m = $i->next;
    do {
        debug "-- starting with permutation : ".(join ' ', map _ascii_pair(@$_), @m)."\n";
        # flip the order of each possible edge
        for my $b (0..(2**(@m)-1)) {
            debug "-- b is $b\n";
            my $m = clone \@m;
            my $k = 0;
            for (@$m) {
                $_ = [$_->[1],$_->[0]] if $b & (1 << $k++);
            }
            my $d = _distance(@$m);
            debug " -- distance for ".(join ' ', map _ascii_pair(@$_), @$m)." : $d\n";
            if (!defined($min_distance) || $d < $min_distance) {
                $min_distance = $d;
                @best = @$m;
            }
        }
        @m = $i->next;
    } until (!@m);
    debug "-- best distance : $min_distance\n";
    return @best;
}

#
# make a subgraph of people who are partners (i.e. married or had kids together)
# also rearranges @people
#
sub _partner_subgraph {
    my ($class,$people) = @_;
    my @people = @$people;
    return '' if @$people==1;
    my @marriages;
    my @parentships;
    for my $p (@people) {
        push @marriages, [ $p, $p->spouse() ] if $p->spouse;
        push @parentships, [ $p, $_ ] for $p->partners;
    }
    my @cluster = (@marriages, @parentships);
    @cluster = _remove_duplicates(@cluster);
    @cluster = _find_best_ordering(@cluster);

    my $best = join ' ', map _ascii_pair(@$_), @cluster;
    debug "** best ordering : $best\n";

    my $graph_name = join '_and_', map $_->get('id'), @people;
    my $output = "subgraph cluster_$graph_name {\n /* $best */\ncolor=white;\n";

    for my $e (@cluster) {
        if (_are_married(@$e)) {
            $output .= $class->_marriage_subgraph(@$e);
        } else {
            $output .= $class->_parent_edge(@$e);
        }
    }

    return "" unless $output && $output =~ /\w/;
    return $output." } \n";
}

#
# intersect two array refs
#
sub _intersection {
   # probably a little slow compared to perldoc -q intersect, but can we use objects as hash keys?
   my ($a,$b) = @_;
   my @i;
   for my $x (@$b) {
     die "undefs in intersection" unless defined $x;
     push @i, $x if grep { $_ eq $x } @$a;
   }
   return @i;
}

#
# node from which a kid comes; a --+-- b
#                                  |
#                                 kid
# the "+" is the kid node.
#
sub _kid_node {
    my ($a,$b) = @_;
    die "no kid node for single parents" unless ($a && $b);
    ($a,$b) = ($b,$a) if $b->get('gender') eq 'm';
    return join '_',$a->get('id'),$b->get('id');
}

#
sub had_kids {
    my ($a,$b) = @_;
    my $x = [map $_->id, $a->kids ];
    my $y = [map $_->id, $b->kids ];
    debug "intersecting ".Dumper($x,$y);
    my @i = _intersection($x,$y);
    debug "number of kids shared by ".$a->id." and ".$b->id." is ".@i."\n";
    return (@i > 0);
}

sub _marriage_subgraph {
    my ($class,$x,$y) = @_;
    my ($one,$two) = map $_->get('id'), ($x,$y);
    my $graph;
    my %k;
    if (had_kids($x,$y)) {
        my $kid_node = _kid_node($x,$y);
        $graph = "$one -- $kid_node -- $two; rank=same;$one $two $kid_node;";
        $graph .= qq+\n$kid_node [label="",width=.01,height=.01]+;
    } else {
        $graph = "$one -- $two; rank=same;$one $two;";
    }
    return "subgraph marriage_${one}_${two} {\nedge [style=bold]; $graph }\n",
}

sub _parent_edge {
    # Draw an edge between two people who had a kid together
    my ($class,$x,$y) = @_;
    my ($one,$two) = map $_->get('id'), ($x,$y);
    my $kid_node = _kid_node($x,$y);
    return join "\n",
        "edge [style=dotted]; $one -- $kid_node -- $two { rank=same;$one $two $kid_node }",
        "$kid_node [ shape=point ]";
}

sub _person_node {
    my ($class, $person) = @_;
    our $urlBase;
    return $person->id . " ["
      . ($person->get('gender') eq 'm' ? 'color="#093AB5"' : 'color="#C666B8"')
      . ' label = "'
      . $class->_person_label($person)
      . qq|" href="$urlBase?id=|
      . $person->id . '"];';
}

sub _person_label {
    my ($class,$p) = @_;
    return join ' ', grep defined($_), $p->get('first_name'), $p->get('last_name');
}

sub DESTROY {
    %Tree::Family::Person::globalHash = ();
}

=head1 SEE ALSO

 Tree::Family::Person
 family.cgi (in this distribution)

=head1 AUTHOR

Brian Duggan, C<<  >>

=head1 BUGS

graphviz uses a lot of heuristics to create a nice layout.  This package
attempts to micro-manage the contents of the dot file in order to produce
a nice layout, while still letting  graphviz do the brunt of the work.
This approach doesn't always produce optimal results.  Patches welcome.

=head1 COPYRIGHT & LICENSE

Copyright 2006 Brian Duggan, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;