[scpubgit/stemmatology.git] / lib / Text / Tradition / Analysis.pm

package Text::Tradition::Analysis;

use strict;
use warnings;
use Benchmark;
use Exporter 'import';
use Text::Tradition;
use Text::Tradition::Stemma;

use vars qw/ @EXPORT_OK /;
@EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;

=head1 NAME

Text::Tradition::Analysis - functions for stemma analysis of a tradition

=head1 SYNOPSIS

  use Text::Tradition;
  use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
  my $t = Text::Tradition->new( 
    'name' => 'this is a text',
    'input' => 'TEI',
    'file' => '/path/to/tei_parallel_seg_file.xml' );
  $t->add_stemma( 'dotfile' => $stemmafile );

  my $variant_data = run_analysis( $tradition );
  # Recalculate rank $n treating all orthographic variants as equivalent
  my $reanalyze = analyze_variant_location( $tradition, $n, 0, 'orthographic' );
    
=head1 DESCRIPTION

Text::Tradition is a library for representation and analysis of collated
texts, particularly medieval ones.  The Collation is the central feature of
a Tradition, where the text, its sequence of readings, and its relationships
between readings are actually kept.

=head1 SUBROUTINES

=head2 run_analysis( $tradition, $stemma_id, @merge_relationship_types )

Runs the analysis described in analyze_variant_location on every location
in the collation of the given tradition, against the stemma specified in
$stemma_id.  If $stemma_id is not specified, it defaults to 0 (referencing
the first stemma saved for the tradition.)

The optional @merge_relationship_types contains a list of relationship types 
to treat as equivalent for the analysis.

=begin testing

use Text::Tradition;
use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;

my $datafile = 't/data/florilegium_tei_ps.xml';
my $tradition = Text::Tradition->new( 'input' => 'TEI',
                                      'name' => 'test0',
                                      'file' => $datafile );
my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
is( ref( $s ), 'Text::Tradition::Stemma', "Added stemma to tradition" );

my $data = run_analysis( $tradition );
# TODO should be 21!
is( $data->{'genealogical_count'}, 42, "Got right genealogical count" );
is( $data->{'conflict_count'}, 17, "Got right conflict count" );
is( $data->{'variant_count'}, 58, "Got right total variant number" );

=end testing

=cut

sub run_analysis {
	my( $tradition, $stemma_id, @collapse ) = @_;
	$stemma_id = 0 unless $stemma_id;
	
	# Run the variant analysis on every rank in the graph that doesn't
	# have a common reading. Return the results.
	my @variants; # holds results from analyze_variant_location
	my $genealogical; # counter of 'genealogical' variants
	my $conflicts;    # counter of conflicting readings
	
	# Find and mark 'common' ranks for exclusion.
	my %common_rank;
	foreach my $rdg ( $tradition->collation->common_readings ) {
		$common_rank{$rdg->rank} = 1;
	}
	
	foreach my $rank ( 1 .. $tradition->collation->end->rank-1 ) {
		next if $common_rank{$rank};
		my $variant_row = analyze_variant_location( 
			$tradition, $rank, $stemma_id, @collapse );
		push( @variants, $variant_row );
		$genealogical++ if $variant_row->{'genealogical'};
		$conflicts += grep { $_->{'conflict'} } @{$variant_row->{'readings'}};
	}
	
	return {
		'variants' => \@variants,
		'variant_count' => scalar @variants, # TODO redundant
		'conflict_count' => $conflicts,
		'genealogical_count' => $genealogical,
		};
}

=head2 group_variants( $tradition, $rank, $lacunose, @merge_relationship_types )

Groups the variants at the given $rank of the collation, treating any
relationships in @merge_relationship_types as equivalent.  $lacunose should
be a reference to an array, to which the sigla of lacunose witnesses at this 
rank will be appended.

Returns two ordered lists $readings, $groups, where $readings->[$n] is attested
by the witnesses listed in $groups->[$n].

=cut

# Return group_readings, groups, lacunose
sub group_variants {
	my( $tradition, $rank, $lacunose, $collapse ) = @_;
	my $c = $tradition->collation;
	# Get the alignment table readings
	my %readings_at_rank;
	my @gap_wits;
	foreach my $tablewit ( @{$tradition->collation->alignment_table->{'alignment'}} ) {
		my $rdg = $tablewit->{'tokens'}->[$rank-1];
		if( $rdg && $rdg->{'t'}->is_lacuna ) {
			push( @$lacunose, $tablewit->{'witness'} );
		} elsif( $rdg ) {
			$readings_at_rank{$rdg->{'t'}->text} = $rdg->{'t'};
		} else {
			push( @gap_wits, $tablewit->{'witness'} );
		}
	}
	
	# Group the readings, collapsing groups by relationship if needed
	my %grouped_readings;
	foreach my $rdg ( sort { $b->witnesses <=> $a->witnesses } values %readings_at_rank ) {
		# Skip readings that have been collapsed into others.
		next if exists $grouped_readings{$rdg->text} && !$grouped_readings{$rdg->text};
		my @wits = $rdg->witnesses;
		if( $collapse ) {
			my $filter = sub { my $r = $_[0]; grep { $_ eq $r->type } @$collapse; };
			foreach my $other ( $rdg->related_readings( $filter ) ) {
				push( @wits, $other->witnesses );
				$grouped_readings{$other->text} = 0;
			}
		}
		$grouped_readings{$rdg->text} = \@wits;	
	}
	$grouped_readings{'(omitted)'} = \@gap_wits if @gap_wits;
	# Get rid of our collapsed readings
	map { delete $grouped_readings{$_} unless $grouped_readings{$_} } 
		keys %grouped_readings 
		if $collapse;
	
	# Return the readings and groups, sorted by size
	my( @readings, @groups );
	foreach my $r ( sort { @{$grouped_readings{$b}} <=> @{$grouped_readings{$a}} }
						keys %grouped_readings ) {
		push( @readings, $r );
		push( @groups, $grouped_readings{$r} );
	}
	return( \@readings, \@groups );
}

=head2 analyze_variant_location( $tradition, $rank, $stemma_id, @merge_relationship_types )

Runs an analysis of the given tradition, at the location given in $rank, 
against the graph of the stemma specified in $stemma_id.  The argument 
@merge_relationship_types is an optional list of relationship types for
which readings so related should be treated as equivalent.

Returns a data structure as follows:

 { 	'id' => $rank,
 	'genealogical' => boolean,
 	'readings => [ { text => $reading_text, 
 					 group => [ witnesses ], 
 					 conflict => [ conflicting ], 
 					 missing => [ excluded ] }, ... ]
 }
where 'conflicting' is the list of witnesses whose readings conflict with
this group, and 'excluded' is the list of witnesses either not present in
the stemma or lacunose at this location.

=cut

sub analyze_variant_location {
	my( $tradition, $rank, $sid, @collapse ) = @_;
	$DB::single = 1 if @collapse;
	# Get the readings in this tradition at this rank
	my @rank_rdgs = grep { $_->rank == $rank } $tradition->collation->readings;
	# Get the applicable stemma
	my $undirected; # TODO Allow undirected distance tree analysis too
	my $stemma = $tradition->stemma( $sid );
	my $graph = $stemma->graph;
	# Figure out which witnesses we are working with
	my @lacunose = _set( 'symmdiff', [ $stemma->witnesses ], 
		[ map { $_->sigil } $tradition->witnesses ] );

	# Now group the readings
	my( $readings, $groups ) = 
		group_variants( $tradition, $rank, \@lacunose, \@collapse );
	my $group_readings = {};
	# Lookup table group string -> readings
	foreach my $x ( 0 .. $#$groups ) {
		$group_readings->{wit_stringify( $groups->[$x] )} = $readings->[$x];
	}

	# Now do the work.	
    my $contig = {};
    my $subgraph = {};
    my $is_conflicted;
    my $conflict = {};
    my $variant_row = { 'id' => $rank, 'readings' => [] };
    # Mark each ms as in its own group, first.
    foreach my $g ( @$groups ) {
        my $gst = wit_stringify( $g );
        map { $contig->{$_} = $gst } @$g;
    }
    # Now for each unmarked node in the graph, initialize an array
    # for possible group memberships.  We will use this later to
    # resolve potential conflicts.
    map { $contig->{$_} = [] unless $contig->{$_} } $graph->vertices;
    foreach my $g ( sort { scalar @$b <=> scalar @$a } @$groups ) {
        my $gst = wit_stringify( $g );  # This is the group name
        my $reachable = { $g->[0] => 1 };
        # Copy the graph, and delete all non-members from the new graph.
        my $part = $graph->copy;
        my $group_root;
        $part->delete_vertices( 
            grep { !ref( $contig->{$_} ) && $contig->{$_} ne $gst } $graph->vertices );
                
        # Now look to see if our group is connected.
        if( $undirected ) { # For use with distance trees etc.
            # Find all vertices reachable from the first (arbitrary) group
            # member.  If we are genealogical this should include them all. 
            map { $reachable->{$_} = 1 } $part->all_reachable( $g->[0] );
            # TODO This is a terrible way to do distance trees, since all
            # non-leaf nodes are included in every graph part now. We may
            # have to go back to SPDP.
        } else {
            if( @$g > 1 ) {
                # Dispense with the trivial case of one reading.
                # We have to take directionality into account.
                # How many root nodes do we have?
                my @roots = grep { ref( $contig->{$_} ) || $contig->{$_} eq $gst } 
                    $part->source_vertices;
                # Assuming that @$g > 1, find the first root node that has at
                # least one successor belonging to our group. If this reading
                # is genealogical, there should be only one, but we will check
                # that implicitly later.
                my $nodes_in_subtree = 0;
                foreach my $root ( @roots ) {
                    # Prune the tree to get rid of extraneous hypotheticals.
                    $root = _prune_subtree( $part, $root, $contig );
                    # Get all the successor nodes of our root.
                    my $tmp_reach = { $root => 1 };
                    map { $tmp_reach->{$_} = 1 } $part->all_successors( $root );
                    # Skip this root if none of our successors are in our group
                    # (e.g. isolated 'hypothetical' witnesses with no group)
                    next unless grep { $contig->{$_} } keys %$tmp_reach;
                    if( keys %$tmp_reach > $nodes_in_subtree ) {
                        $nodes_in_subtree = keys %$tmp_reach;
                        $reachable = $tmp_reach;
                        $group_root = $root;
                    }
                }
            } # else it is a single-node group, nothing to calculate.
        }
        
        # None of the 'reachable' nodes should be marked as being in another 
        # group.  Paint the 'hypotheticals' with our group while we are at it,
        # unless there is a conflict present.
        foreach ( keys %$reachable ) {
            if( ref $contig->{$_} ) {
                push( @{$contig->{$_}}, $gst );
            } elsif( $contig->{$_} ne $gst ) {
                $conflict->{$group_readings->{$gst}} = $group_readings->{$contig->{$_}};
            } # else it is an 'extant' node marked with our group already.
        }
        # None of the unreachable nodes should be in our group either.
        foreach ( $part->vertices ) {
            next if $reachable->{$_};
            if( $contig->{$_} eq $gst ) {
                $conflict->{$group_readings->{$gst}} = $group_readings->{$gst};
                last;
            }
        }
        
        # Now, if we have a conflict, we can write the reading in full.  If not, 
        # we have to save the subgraph so that we can resolve possible conflicts 
        # on hypothetical nodes.
        $is_conflicted = 1 if exists $conflict->{$group_readings->{$gst}};
        
        # Write the reading.
        my $reading = { 'text' => $group_readings->{$gst},
                        'missing' => wit_stringify( \@lacunose ),
                        'group' => $gst };  # This will change if we find no conflict
        if( $is_conflicted ) {
            $reading->{'conflict'} = $conflict->{$group_readings->{$gst}}
        } else {
            # Save the relevant subgraph.
            $subgraph->{$gst} = { 'graph' => $part,
                                'root' => $group_root,
                                'reachable' => $reachable };
        }
        push( @{$variant_row->{'readings'}}, $reading );
    }
    
    # Now that we have gone through all the rows, check the hypothetical
    # readings for conflict if we haven't found one yet.
    if( keys %$subgraph && !keys %$conflict ) {
        my @resolve;
        foreach ( keys %$contig ) {
            next unless ref $contig->{$_};
            if( scalar @{$contig->{$_}} > 1 ) {
                push( @resolve, $_ );
            } else {
                $contig->{$_} = scalar @{$contig->{$_}} ? $contig->{$_}->[0] : '';
            }
        }
        # Do we still have a possible conflict?
        my $still_contig = {};
        foreach my $h ( @resolve ) {
            # For each of the hypothetical readings with more than one possibility,
            # try deleting it from each of its member subgraphs in turn, and see
            # if that breaks the contiguous grouping.
            # TODO This can still break in a corner case where group A can use 
            # either vertex 1 or 2, and group B can use either vertex 2 or 1.
            # Revisit this if necessary; it could get brute-force nasty.
            foreach my $gst ( @{$contig->{$h}} ) {
                my $gpart = $subgraph->{$gst}->{'graph'}->copy;
                my $reachable = $subgraph->{$gst}->{'reachable'};
                $gpart->delete_vertex( $h );
                # Is everything else still reachable from the root?
                # TODO If $h was the root, see if we still have a single root.
                my %still_reachable = ( $subgraph->{$gst}->{'root'} => 1 );
                map { $still_reachable{$_} = 1 }
                    $gpart->all_successors( $subgraph->{$gst}->{'root'} );
                foreach my $v ( keys %$reachable ) {
                    next if $v eq $h;
                    if( !$still_reachable{$v}
                        && ( $contig->{$v} eq $gst 
                             || ( exists $still_contig->{$v} 
                                  && $still_contig->{$v} eq $gst ) ) ) {
                        # We need $h.
                        if( exists $still_contig->{$h} ) {
                            # Conflict!
                            $conflict->{$group_readings->{$gst}} = 
                                $group_readings->{$still_contig->{$h}};
                        } else {
                            $still_contig->{$h} = $gst;
                        }
                        last;
                    } # else we don't need $h in this group.
                }
            }
        }
        
        # Now, assuming no conflict, we have some hypothetical vertices in
        # $still_contig that are the "real" group memberships.  Replace these
        # in $contig.
        unless ( keys %$conflict ) {
            foreach my $v ( keys %$contig ) {
                next unless ref $contig->{$v};
                $contig->{$v} = $still_contig->{$v};
            }
        }
    }
            
    # Now write the group and conflict information into the respective rows.
    my %missing;
	map { $missing{$_} = 1 } @lacunose; # quick lookup table
    foreach my $rdg ( @{$variant_row->{'readings'}} ) {
        $rdg->{'conflict'} = $conflict->{$rdg->{'text'}};
        next if $rdg->{'conflict'};
        my @members = grep { $contig->{$_} eq $rdg->{'group'} && !$missing{$_} } 
            keys %$contig;
        $rdg->{'group'} = wit_stringify( \@members );
    }
    
    $variant_row->{'genealogical'} = !( keys %$conflict );
    return $variant_row;
}

sub _prune_subtree {
    my( $tree, $root, $contighash ) = @_;
    # First, delete hypothetical leaves / orphans until there are none left.
    my @orphan_hypotheticals = grep { ref( $contighash->{$_} ) } 
        $tree->successorless_vertices;
    while( @orphan_hypotheticals ) {
        $tree->delete_vertices( @orphan_hypotheticals );
        @orphan_hypotheticals = grep { ref( $contighash->{$_} ) } 
            $tree->successorless_vertices;
    }
    # Then delete a hypothetical root with only one successor, moving the
    # root to the child.
    while( $tree->successors( $root ) == 1 && ref $contighash->{$root} ) {
        my @nextroot = $tree->successors( $root );
        $tree->delete_vertex( $root );
        $root = $nextroot[0];
    }
    # The tree has been modified in place, but we need to know the new root.
    return $root;
}
# Add the variant, subject to a.c. representation logic.
# This assumes that we will see the 'main' version before the a.c. version.
sub add_variant_wit {
    my( $arr, $wit, $acstr ) = @_;
    my $skip;
    if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
        my $real = $1;
        $skip = grep { $_ =~ /^\Q$real\E$/ } @$arr;
    } 
    push( @$arr, $wit ) unless $skip;
}

=head2 wit_stringify( $groups )

Takes an array of witness groupings and produces a string like
['A','B'] / ['C','D','E'] / ['F']

=cut

sub wit_stringify {
    my $groups = shift;
    my @gst;
    # If we were passed an array of witnesses instead of an array of 
    # groupings, then "group" the witnesses first.
    unless( ref( $groups->[0] ) ) {
        my $mkgrp = [ $groups ];
        $groups = $mkgrp;
    }
    foreach my $g ( @$groups ) {
        push( @gst, '[' . join( ',', map { "'$_'" } @$g ) . ']' );
    }
    return join( ' / ', @gst );
}

sub _set {
	my( $op, $lista, $listb ) = @_;
	my %union;
	my %scalars;
	map { $union{$_} = 1; $scalars{$_} = $_ } @$lista;
	map { $union{$_} += 1; $scalars{$_} = $_ } @$listb;
	my @set;
	if( $op eq 'intersection' ) {
		@set = grep { $union{$_} == 2 } keys %union;
	} elsif( $op eq 'symmdiff' ) {
		@set = grep { $union{$_} == 1 } keys %union;
	} elsif( $op eq 'union' ) {
		@set = keys %union;
	}
	return map { $scalars{$_} } @set;
}

1;

=head1 LICENSE

This package is free software and is provided "as is" without express
or implied warranty.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Tara L Andrews E<lt>aurum@cpan.orgE<gt>
Commit	Line	Data
d71100ed	1	package Text::Tradition::Analysis;
	2
	3	use strict;
	4	use warnings;
e4386ba9	5	use Benchmark;
d1348d38	6	use Exporter 'import';
d71100ed	7	use Text::Tradition;
	8	use Text::Tradition::Stemma;
	9
d1348d38	10	use vars qw/ @EXPORT_OK /;
a2cf85dd	11	@EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;
d1348d38	12
7f52eac8	13	=head1 NAME
	14
	15	Text::Tradition::Analysis - functions for stemma analysis of a tradition
	16
	17	=head1 SYNOPSIS
	18
	19	use Text::Tradition;
	20	use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
	21	my $t = Text::Tradition->new(
	22	'name' => 'this is a text',
	23	'input' => 'TEI',
	24	'file' => '/path/to/tei_parallel_seg_file.xml' );
	25	$t->add_stemma( 'dotfile' => $stemmafile );
	26
	27	my $variant_data = run_analysis( $tradition );
	28	# Recalculate rank $n treating all orthographic variants as equivalent
	29	my $reanalyze = analyze_variant_location( $tradition, $n, 0, 'orthographic' );
	30
	31	=head1 DESCRIPTION
	32
	33	Text::Tradition is a library for representation and analysis of collated
	34	texts, particularly medieval ones. The Collation is the central feature of
	35	a Tradition, where the text, its sequence of readings, and its relationships
	36	between readings are actually kept.
	37
	38	=head1 SUBROUTINES
	39
	40	=head2 run_analysis( $tradition, $stemma_id, @merge_relationship_types )
	41
	42	Runs the analysis described in analyze_variant_location on every location
	43	in the collation of the given tradition, against the stemma specified in
	44	$stemma_id. If $stemma_id is not specified, it defaults to 0 (referencing
	45	the first stemma saved for the tradition.)
	46
	47	The optional @merge_relationship_types contains a list of relationship types
	48	to treat as equivalent for the analysis.
	49
	50	=begin testing
	51
	52	use Text::Tradition;
	53	use Text::Tradition::Analysis qw/ run_analysis analyze_variant_location /;
	54
	55	my $datafile = 't/data/florilegium_tei_ps.xml';
	56	my $tradition = Text::Tradition->new( 'input' => 'TEI',
	57	'name' => 'test0',
	58	'file' => $datafile );
	59	my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
	60	is( ref( $s ), 'Text::Tradition::Stemma', "Added stemma to tradition" );
	61
	62	my $data = run_analysis( $tradition );
	63	# TODO should be 21!
	64	is( $data->{'genealogical_count'}, 42, "Got right genealogical count" );
	65	is( $data->{'conflict_count'}, 17, "Got right conflict count" );
	66	is( $data->{'variant_count'}, 58, "Got right total variant number" );
	67
	68	=end testing
	69
	70	=cut
	71
d71100ed	72	sub run_analysis {
7f52eac8	73	my( $tradition, $stemma_id, @collapse ) = @_;
7f52eac8	74	$stemma_id = 0 unless $stemma_id;
56cf65bd	75
7f52eac8	76	# Run the variant analysis on every rank in the graph that doesn't
	77	# have a common reading. Return the results.
	78	my @variants; # holds results from analyze_variant_location
	79	my $genealogical; # counter of 'genealogical' variants
	80	my $conflicts; # counter of conflicting readings
d71100ed	81
7f52eac8	82	# Find and mark 'common' ranks for exclusion.
	83	my %common_rank;
	84	foreach my $rdg ( $tradition->collation->common_readings ) {
	85	$common_rank{$rdg->rank} = 1;
d71100ed	86	}
7f52eac8	87
	88	foreach my $rank ( 1 .. $tradition->collation->end->rank-1 ) {
	89	next if $common_rank{$rank};
	90	my $variant_row = analyze_variant_location(
	91	$tradition, $rank, $stemma_id, @collapse );
	92	push( @variants, $variant_row );
	93	$genealogical++ if $variant_row->{'genealogical'};
	94	$conflicts += grep { $_->{'conflict'} } @{$variant_row->{'readings'}};
d71100ed	95	}
d71100ed	96
7f52eac8	97	return {
	98	'variants' => \@variants,
	99	'variant_count' => scalar @variants, # TODO redundant
	100	'conflict_count' => $conflicts,
	101	'genealogical_count' => $genealogical,
	102	};
d71100ed	103	}
d71100ed	104
7f52eac8	105	=head2 group_variants( $tradition, $rank, $lacunose, @merge_relationship_types )
	106
	107	Groups the variants at the given $rank of the collation, treating any
	108	relationships in @merge_relationship_types as equivalent. $lacunose should
	109	be a reference to an array, to which the sigla of lacunose witnesses at this
	110	rank will be appended.
	111
	112	Returns two ordered lists $readings, $groups, where $readings->[$n] is attested
	113	by the witnesses listed in $groups->[$n].
	114
	115	=cut
	116
	117	# Return group_readings, groups, lacunose
d1348d38	118	sub group_variants {
7f52eac8	119	my( $tradition, $rank, $lacunose, $collapse ) = @_;
	120	my $c = $tradition->collation;
	121	# Get the alignment table readings
	122	my %readings_at_rank;
	123	my @gap_wits;
	124	foreach my $tablewit ( @{$tradition->collation->alignment_table->{'alignment'}} ) {
	125	my $rdg = $tablewit->{'tokens'}->[$rank-1];
	126	if( $rdg && $rdg->{'t'}->is_lacuna ) {
	127	push( @$lacunose, $tablewit->{'witness'} );
	128	} elsif( $rdg ) {
	129	$readings_at_rank{$rdg->{'t'}->text} = $rdg->{'t'};
	130	} else {
	131	push( @gap_wits, $tablewit->{'witness'} );
	132	}
	133	}
d1348d38	134
7f52eac8	135	# Group the readings, collapsing groups by relationship if needed
	136	my %grouped_readings;
	137	foreach my $rdg ( sort { $b->witnesses <=> $a->witnesses } values %readings_at_rank ) {
	138	# Skip readings that have been collapsed into others.
	139	next if exists $grouped_readings{$rdg->text} && !$grouped_readings{$rdg->text};
	140	my @wits = $rdg->witnesses;
	141	if( $collapse ) {
	142	my $filter = sub { my $r = $_[0]; grep { $_ eq $r->type } @$collapse; };
	143	foreach my $other ( $rdg->related_readings( $filter ) ) {
	144	push( @wits, $other->witnesses );
	145	$grouped_readings{$other->text} = 0;
d1348d38	146	}
d1348d38	147	}
7f52eac8	148	$grouped_readings{$rdg->text} = \@wits;
	149	}
	150	$grouped_readings{'(omitted)'} = \@gap_wits if @gap_wits;
	151	# Get rid of our collapsed readings
	152	map { delete $grouped_readings{$_} unless $grouped_readings{$_} }
	153	keys %grouped_readings
	154	if $collapse;
	155
	156	# Return the readings and groups, sorted by size
	157	my( @readings, @groups );
	158	foreach my $r ( sort { @{$grouped_readings{$b}} <=> @{$grouped_readings{$a}} }
	159	keys %grouped_readings ) {
	160	push( @readings, $r );
	161	push( @groups, $grouped_readings{$r} );
d1348d38	162	}
7f52eac8	163	return( \@readings, \@groups );
d1348d38	164	}
d1348d38	165
7f52eac8	166	=head2 analyze_variant_location( $tradition, $rank, $stemma_id, @merge_relationship_types )
f6c8ea08	167
7f52eac8	168	Runs an analysis of the given tradition, at the location given in $rank,
	169	against the graph of the stemma specified in $stemma_id. The argument
	170	@merge_relationship_types is an optional list of relationship types for
	171	which readings so related should be treated as equivalent.
f6c8ea08	172
7f52eac8	173	Returns a data structure as follows:
	174
	175	{ 'id' => $rank,
	176	'genealogical' => boolean,
	177	'readings => [ { text => $reading_text,
	178	group => [ witnesses ],
	179	conflict => [ conflicting ],
	180	missing => [ excluded ] }, ... ]
	181	}
	182	where 'conflicting' is the list of witnesses whose readings conflict with
	183	this group, and 'excluded' is the list of witnesses either not present in
	184	the stemma or lacunose at this location.
	185
	186	=cut
732152b1	187
d71100ed	188	sub analyze_variant_location {
7f52eac8	189	my( $tradition, $rank, $sid, @collapse ) = @_;
	190	$DB::single = 1 if @collapse;
	191	# Get the readings in this tradition at this rank
	192	my @rank_rdgs = grep { $_->rank == $rank } $tradition->collation->readings;
	193	# Get the applicable stemma
	194	my $undirected; # TODO Allow undirected distance tree analysis too
	195	my $stemma = $tradition->stemma( $sid );
	196	my $graph = $stemma->graph;
	197	# Figure out which witnesses we are working with
	198	my @lacunose = _set( 'symmdiff', [ $stemma->witnesses ],
	199	[ map { $_->sigil } $tradition->witnesses ] );
	200
	201	# Now group the readings
	202	my( $readings, $groups ) =
	203	group_variants( $tradition, $rank, \@lacunose, \@collapse );
	204	my $group_readings = {};
	205	# Lookup table group string -> readings
	206	foreach my $x ( 0 .. $#$groups ) {
	207	$group_readings->{wit_stringify( $groups->[$x] )} = $readings->[$x];
	208	}
	209
	210	# Now do the work.
231d71fc	211	my $contig = {};
231d71fc	212	my $subgraph = {};
c4a4fb1b	213	my $is_conflicted;
d71100ed	214	my $conflict = {};
7f52eac8	215	my $variant_row = { 'id' => $rank, 'readings' => [] };
94a077d6	216	# Mark each ms as in its own group, first.
	217	foreach my $g ( @$groups ) {
	218	my $gst = wit_stringify( $g );
231d71fc	219	map { $contig->{$_} = $gst } @$g;
94a077d6	220	}
c4a4fb1b	221	# Now for each unmarked node in the graph, initialize an array
	222	# for possible group memberships. We will use this later to
	223	# resolve potential conflicts.
231d71fc	224	map { $contig->{$_} = [] unless $contig->{$_} } $graph->vertices;
d71100ed	225	foreach my $g ( sort { scalar @$b <=> scalar @$a } @$groups ) {
c4a4fb1b	226	my $gst = wit_stringify( $g ); # This is the group name
c4a4fb1b	227	my $reachable = { $g->[0] => 1 };
08e0fb85	228	# Copy the graph, and delete all non-members from the new graph.
c4a4fb1b	229	my $part = $graph->copy;
	230	my $group_root;
	231	$part->delete_vertices(
231d71fc	232	grep { !ref( $contig->{$_} ) && $contig->{$_} ne $gst } $graph->vertices );
c4a4fb1b	233
	234	# Now look to see if our group is connected.
	235	if( $undirected ) { # For use with distance trees etc.
	236	# Find all vertices reachable from the first (arbitrary) group
	237	# member. If we are genealogical this should include them all.
	238	map { $reachable->{$_} = 1 } $part->all_reachable( $g->[0] );
	239	# TODO This is a terrible way to do distance trees, since all
	240	# non-leaf nodes are included in every graph part now. We may
	241	# have to go back to SPDP.
	242	} else {
	243	if( @$g > 1 ) {
	244	# Dispense with the trivial case of one reading.
	245	# We have to take directionality into account.
	246	# How many root nodes do we have?
231d71fc	247	my @roots = grep { ref( $contig->{$_} ) \|\| $contig->{$_} eq $gst }
c4a4fb1b	248	$part->source_vertices;
	249	# Assuming that @$g > 1, find the first root node that has at
	250	# least one successor belonging to our group. If this reading
	251	# is genealogical, there should be only one, but we will check
	252	# that implicitly later.
	253	my $nodes_in_subtree = 0;
	254	foreach my $root ( @roots ) {
231d71fc	255	# Prune the tree to get rid of extraneous hypotheticals.
7f52eac8	256	$root = _prune_subtree( $part, $root, $contig );
c4a4fb1b	257	# Get all the successor nodes of our root.
	258	my $tmp_reach = { $root => 1 };
	259	map { $tmp_reach->{$_} = 1 } $part->all_successors( $root );
	260	# Skip this root if none of our successors are in our group
	261	# (e.g. isolated 'hypothetical' witnesses with no group)
231d71fc	262	next unless grep { $contig->{$_} } keys %$tmp_reach;
c4a4fb1b	263	if( keys %$tmp_reach > $nodes_in_subtree ) {
	264	$nodes_in_subtree = keys %$tmp_reach;
	265	$reachable = $tmp_reach;
	266	$group_root = $root;
	267	}
	268	}
	269	} # else it is a single-node group, nothing to calculate.
	270	}
	271
	272	# None of the 'reachable' nodes should be marked as being in another
	273	# group. Paint the 'hypotheticals' with our group while we are at it,
	274	# unless there is a conflict present.
	275	foreach ( keys %$reachable ) {
231d71fc	276	if( ref $contig->{$_} ) {
	277	push( @{$contig->{$_}}, $gst );
	278	} elsif( $contig->{$_} ne $gst ) {
	279	$conflict->{$group_readings->{$gst}} = $group_readings->{$contig->{$_}};
c4a4fb1b	280	} # else it is an 'extant' node marked with our group already.
d71100ed	281	}
08e0fb85	282	# None of the unreachable nodes should be in our group either.
08e0fb85	283	foreach ( $part->vertices ) {
c4a4fb1b	284	next if $reachable->{$_};
231d71fc	285	if( $contig->{$_} eq $gst ) {
c4a4fb1b	286	$conflict->{$group_readings->{$gst}} = $group_readings->{$gst};
	287	last;
	288	}
08e0fb85	289	}
08e0fb85	290
c4a4fb1b	291	# Now, if we have a conflict, we can write the reading in full. If not,
	292	# we have to save the subgraph so that we can resolve possible conflicts
	293	# on hypothetical nodes.
	294	$is_conflicted = 1 if exists $conflict->{$group_readings->{$gst}};
	295
732152b1	296	# Write the reading.
732152b1	297	my $reading = { 'text' => $group_readings->{$gst},
7f52eac8	298	'missing' => wit_stringify( \@lacunose ),
c4a4fb1b	299	'group' => $gst }; # This will change if we find no conflict
	300	if( $is_conflicted ) {
	301	$reading->{'conflict'} = $conflict->{$group_readings->{$gst}}
732152b1	302	} else {
c4a4fb1b	303	# Save the relevant subgraph.
231d71fc	304	$subgraph->{$gst} = { 'graph' => $part,
c4a4fb1b	305	'root' => $group_root,
c4a4fb1b	306	'reachable' => $reachable };
732152b1	307	}
732152b1	308	push( @{$variant_row->{'readings'}}, $reading );
d71100ed	309	}
c4a4fb1b	310
	311	# Now that we have gone through all the rows, check the hypothetical
	312	# readings for conflict if we haven't found one yet.
231d71fc	313	if( keys %$subgraph && !keys %$conflict ) {
c4a4fb1b	314	my @resolve;
231d71fc	315	foreach ( keys %$contig ) {
	316	next unless ref $contig->{$_};
	317	if( scalar @{$contig->{$_}} > 1 ) {
c4a4fb1b	318	push( @resolve, $_ );
c4a4fb1b	319	} else {
231d71fc	320	$contig->{$_} = scalar @{$contig->{$_}} ? $contig->{$_}->[0] : '';
c4a4fb1b	321	}
	322	}
	323	# Do we still have a possible conflict?
231d71fc	324	my $still_contig = {};
c4a4fb1b	325	foreach my $h ( @resolve ) {
	326	# For each of the hypothetical readings with more than one possibility,
	327	# try deleting it from each of its member subgraphs in turn, and see
	328	# if that breaks the contiguous grouping.
	329	# TODO This can still break in a corner case where group A can use
	330	# either vertex 1 or 2, and group B can use either vertex 2 or 1.
	331	# Revisit this if necessary; it could get brute-force nasty.
231d71fc	332	foreach my $gst ( @{$contig->{$h}} ) {
	333	my $gpart = $subgraph->{$gst}->{'graph'}->copy;
	334	my $reachable = $subgraph->{$gst}->{'reachable'};
c4a4fb1b	335	$gpart->delete_vertex( $h );
	336	# Is everything else still reachable from the root?
	337	# TODO If $h was the root, see if we still have a single root.
231d71fc	338	my %still_reachable = ( $subgraph->{$gst}->{'root'} => 1 );
c4a4fb1b	339	map { $still_reachable{$_} = 1 }
231d71fc	340	$gpart->all_successors( $subgraph->{$gst}->{'root'} );
c4a4fb1b	341	foreach my $v ( keys %$reachable ) {
	342	next if $v eq $h;
	343	if( !$still_reachable{$v}
231d71fc	344	&& ( $contig->{$v} eq $gst
	345	\|\| ( exists $still_contig->{$v}
	346	&& $still_contig->{$v} eq $gst ) ) ) {
c4a4fb1b	347	# We need $h.
231d71fc	348	if( exists $still_contig->{$h} ) {
c4a4fb1b	349	# Conflict!
c4a4fb1b	350	$conflict->{$group_readings->{$gst}} =
231d71fc	351	$group_readings->{$still_contig->{$h}};
c4a4fb1b	352	} else {
231d71fc	353	$still_contig->{$h} = $gst;
c4a4fb1b	354	}
	355	last;
	356	} # else we don't need $h in this group.
	357	}
	358	}
	359	}
	360
	361	# Now, assuming no conflict, we have some hypothetical vertices in
	362	# $still_contig that are the "real" group memberships. Replace these
	363	# in $contig.
	364	unless ( keys %$conflict ) {
231d71fc	365	foreach my $v ( keys %$contig ) {
	366	next unless ref $contig->{$v};
	367	$contig->{$v} = $still_contig->{$v};
c4a4fb1b	368	}
	369	}
	370	}
	371
	372	# Now write the group and conflict information into the respective rows.
7f52eac8	373	my %missing;
7f52eac8	374	map { $missing{$_} = 1 } @lacunose; # quick lookup table
c4a4fb1b	375	foreach my $rdg ( @{$variant_row->{'readings'}} ) {
	376	$rdg->{'conflict'} = $conflict->{$rdg->{'text'}};
	377	next if $rdg->{'conflict'};
7f52eac8	378	my @members = grep { $contig->{$_} eq $rdg->{'group'} && !$missing{$_} }
231d71fc	379	keys %$contig;
c4a4fb1b	380	$rdg->{'group'} = wit_stringify( \@members );
	381	}
	382
08e0fb85	383	$variant_row->{'genealogical'} = !( keys %$conflict );
732152b1	384	return $variant_row;
d71100ed	385	}
d71100ed	386
7f52eac8	387	sub _prune_subtree {
231d71fc	388	my( $tree, $root, $contighash ) = @_;
	389	# First, delete hypothetical leaves / orphans until there are none left.
	390	my @orphan_hypotheticals = grep { ref( $contighash->{$_} ) }
	391	$tree->successorless_vertices;
	392	while( @orphan_hypotheticals ) {
	393	$tree->delete_vertices( @orphan_hypotheticals );
	394	@orphan_hypotheticals = grep { ref( $contighash->{$_} ) }
	395	$tree->successorless_vertices;
	396	}
	397	# Then delete a hypothetical root with only one successor, moving the
	398	# root to the child.
	399	while( $tree->successors( $root ) == 1 && ref $contighash->{$root} ) {
	400	my @nextroot = $tree->successors( $root );
	401	$tree->delete_vertex( $root );
	402	$root = $nextroot[0];
	403	}
	404	# The tree has been modified in place, but we need to know the new root.
	405	return $root;
	406	}
d71100ed	407	# Add the variant, subject to a.c. representation logic.
	408	# This assumes that we will see the 'main' version before the a.c. version.
	409	sub add_variant_wit {
	410	my( $arr, $wit, $acstr ) = @_;
	411	my $skip;
	412	if( $wit =~ /^(.*)\Q$acstr\E$/ ) {
	413	my $real = $1;
	414	$skip = grep { $_ =~ /^\Q$real\E$/ } @$arr;
	415	}
	416	push( @$arr, $wit ) unless $skip;
	417	}
	418
7f52eac8	419	=head2 wit_stringify( $groups )
	420
	421	Takes an array of witness groupings and produces a string like
	422	['A','B'] / ['C','D','E'] / ['F']
d71100ed	423
7f52eac8	424	=cut
d71100ed	425
	426	sub wit_stringify {
	427	my $groups = shift;
	428	my @gst;
	429	# If we were passed an array of witnesses instead of an array of
	430	# groupings, then "group" the witnesses first.
	431	unless( ref( $groups->[0] ) ) {
	432	my $mkgrp = [ $groups ];
	433	$groups = $mkgrp;
	434	}
	435	foreach my $g ( @$groups ) {
	436	push( @gst, '[' . join( ',', map { "'$_'" } @$g ) . ']' );
	437	}
	438	return join( ' / ', @gst );
	439	}
7f52eac8	440
	441	sub _set {
	442	my( $op, $lista, $listb ) = @_;
	443	my %union;
	444	my %scalars;
	445	map { $union{$_} = 1; $scalars{$_} = $_ } @$lista;
	446	map { $union{$_} += 1; $scalars{$_} = $_ } @$listb;
	447	my @set;
	448	if( $op eq 'intersection' ) {
	449	@set = grep { $union{$_} == 2 } keys %union;
	450	} elsif( $op eq 'symmdiff' ) {
	451	@set = grep { $union{$_} == 1 } keys %union;
	452	} elsif( $op eq 'union' ) {
	453	@set = keys %union;
	454	}
	455	return map { $scalars{$_} } @set;
	456	}
	457
	458	1;
	459
	460	=head1 LICENSE
	461
	462	This package is free software and is provided "as is" without express
	463	or implied warranty. You can redistribute it and/or modify it under
	464	the same terms as Perl itself.
	465
	466	=head1 AUTHOR
	467
	468	Tara L Andrews E<lt>aurum@cpan.orgE<gt>