X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FAnalysis.pm;h=535843543c0ca3cfb379913bac3d4540e98f2cda;hb=88a6bac5ee5b38c4544a0cb58b67f8ee37b8b023;hp=7146227a61b884b5ce2bba83891ef1e04dfad500;hpb=5be0cdeb978d5ebacb5f73ecc5a7f027b7090aa7;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Analysis.pm b/lib/Text/Tradition/Analysis.pm
index 7146227..5358435 100644
--- a/lib/Text/Tradition/Analysis.pm
+++ b/lib/Text/Tradition/Analysis.pm
@@ -3,7 +3,10 @@ package Text::Tradition::Analysis;
 use strict;
 use warnings;
 use Benchmark;
+use Encode qw/ encode_utf8 /;
 use Exporter 'import';
+use JSON qw/ encode_json decode_json /;
+use LWP::UserAgent;
 use Text::Tradition;
 use Text::Tradition::Stemma;
 
@@ -37,15 +40,22 @@ between readings are actually kept.
 
 =head1 SUBROUTINES
 
-=head2 run_analysis( $tradition, $stemma_id, @merge_relationship_types )
+=head2 run_analysis( $tradition, %opts )
 
-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.)
+Runs the analysis described in analyze_variant_location on every location in the 
+collation of the given tradition, with the given options. These include:
 
-The optional @merge_relationship_types contains a list of relationship types 
-to treat as equivalent for the analysis.
+=over 4
+
+=item * stemma_id - Specify which of the tradition's stemmata to use. Default
+is 0 (i.e. the first).
+
+=item * ranks - Specify a list of location ranks to analyze; exclude the rest.
+
+=item * merge_types - Specify a list of relationship types, where related readings 
+should be treated as identical for the purposes of analysis.
+
+=back
 
 =begin testing
 
@@ -59,9 +69,42 @@ my $tradition = Text::Tradition->new( 'input' => 'TEI',
 my $s = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
 is( ref( $s ), 'Text::Tradition::Stemma', "Added stemma to tradition" );
 
+my %expected_genealogical = (
+	1 => '',
+	2 => 1,
+	3 =>  '',
+	5 =>  '',
+	7 =>  '',
+	8 =>  '',
+	10 => '',
+	13 => 1,
+	33 => '',
+	34 => '',
+	37 => '',
+	60 => '',
+	81 => 1,
+	84 => '',
+	87 => '',
+	101 => '',
+	102 => '',
+	122 => 1,
+	157 => '',
+	166 => 1,
+	169 => 1,
+	200 => 1,
+	216 => 1,
+	217 => 1,
+	219 => 1,
+	241 => 1,
+	242 => 1,
+	243 => 1,
+);
+
 my $data = run_analysis( $tradition );
-# TODO Check genealogical count
-is( $data->{'genealogical_count'}, 13, "Got right genealogical count" );
+foreach my $row ( @{$data->{'variants'}} ) {
+	is( $row->{'genealogical'}, $expected_genealogical{$row->{'id'}}, 
+		"Got correct genealogical flag for row " . $row->{'id'} );
+}
 is( $data->{'conflict_count'}, 16, "Got right conflict count" );
 is( $data->{'variant_count'}, 28, "Got right total variant number" );
 
@@ -70,37 +113,51 @@ is( $data->{'variant_count'}, 28, "Got right total variant number" );
 =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
+	my( $tradition, %opts ) = @_;
+	my $c = $tradition->collation;
+
+	my $stemma_id = $opts{'stemma_id'} || 0;
+	my @ranks = @{$opts{'ranks'}} if ref( $opts{'ranks'} ) eq 'ARRAY';
+	my @collapse = @{$opts{'merge_types'}} if ref( $opts{'merge_types'} ) eq 'ARRAY';
+
+	# Get the stemma	
+	my $stemma = $tradition->stemma( $stemma_id );
+	# Figure out which witnesses we are working with
+	my @lacunose = $stemma->hypotheticals;
+	push( @lacunose, _symmdiff( [ $stemma->witnesses ], 
+		[ map { $_->sigil } $tradition->witnesses ] ) );
+
+	# Find and mark 'common' ranks for exclusion, unless they were
+	# explicitly specified.
+	unless( @ranks ) {
+		my %common_rank;
+		foreach my $rdg ( $tradition->collation->common_readings ) {
+			$common_rank{$rdg->rank} = 1;
+		}
+		@ranks = grep { !$common_rank{$_} } ( 1 .. $c->end->rank-1 );
+	}
 	
-	# Find and mark 'common' ranks for exclusion.
-	my %common_rank;
-	foreach my $rdg ( $tradition->collation->common_readings ) {
-		$common_rank{$rdg->rank} = 1;
+	# Group the variants to send to the solver
+	my @groups;
+	foreach my $rank ( @ranks ) {
+		push( @groups, group_variants( $tradition, $rank, \@lacunose, \@collapse ) );
 	}
 	
-	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 );
-		next unless $variant_row;
-		push( @variants, $variant_row );
-		$genealogical++ if $variant_row->{'genealogical'};
-		$conflicts += grep { $_->{'conflict'} } @{$variant_row->{'readings'}};
+	# Parse the answer
+	my $answer = solve_variants( $stemma->editable( ' ' ), @groups );
+	
+	# Do further analysis on the answer
+	foreach my $idx ( 0 .. $#ranks ) {
+		my $location = $answer->{'variants'}->[$idx];
+		# Add the rank back in
+		$location->{'id'} = $ranks[$idx];
+		# Run the extra analysis we need.
+		# For each reading we need missing, conflict, reading_parents,
+		#  independent_occurrence, followed, not_followed, follow_unknown
+		analyze_location( $tradition, $stemma->graph, $location );
 	}
 	
-	return {
-		'variants' => \@variants,
-		'variant_count' => scalar @variants, # TODO redundant
-		'conflict_count' => $conflicts,
-		'genealogical_count' => $genealogical,
-		};
+	return $answer;
 }
 
 =head2 group_variants( $tradition, $rank, $lacunose, @merge_relationship_types )
@@ -139,16 +196,16 @@ sub group_variants {
 	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};
+		next if exists $grouped_readings{$rdg->id} && !$grouped_readings{$rdg->id};
 		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{$other->id} = 0;
 			}
 		}
-		$grouped_readings{$rdg->text} = \@wits;	
+		$grouped_readings{$rdg->id} = \@wits;	
 	}
 	$grouped_readings{'(omitted)'} = \@gap_wits if @gap_wits;
 	# Get rid of our collapsed readings
@@ -159,6 +216,78 @@ sub group_variants {
 	return \%grouped_readings;
 }
 
+=head2 solve_variants( $graph, @groups ) 
+
+Sends the set of groups to the external graph solver service and returns
+a cleaned-up answer, adding the rank IDs back where they belong.
+
+The JSON has the form 
+  { "graph": [ stemmagraph DOT string without newlines ],
+    "groupings": [ array of arrays of groups, one per rank ] }
+    
+The answer has the form 
+  { "variants" => [ array of variant location structures ],
+    "variant_count" => total,
+    "conflict_count" => number of conflicts detected,
+    "genealogical_count" => number of solutions found }
+    
+=cut
+
+sub solve_variants {
+	my( $graph, @groups ) = @_;
+
+	# Make the json with stemma + groups
+	my $jsonstruct = { 'graph' => $graph, 'groupings' => [] };
+	foreach my $ghash ( @groups ) {
+		my @grouping;
+		foreach my $k ( sort keys %$ghash ) {
+			push( @grouping, $ghash->{$k} );
+		}
+		push( @{$jsonstruct->{'groupings'}}, \@grouping );
+	}
+	my $json = encode_json( $jsonstruct );
+
+	# Send it off and get the result
+	my $solver_url = 'http://byzantini.st/cgi-bin/graphcalc.cgi';
+	my $ua = LWP::UserAgent->new();
+	my $resp = $ua->post( $solver_url, 'Content-Type' => 'application/json', 
+						  'Content' => $json );
+						  
+	my $answer;
+	if( $resp->is_success ) {
+		$answer = decode_json( $resp->content );
+	} else {
+		# Either throw an error or fall back to the old method.
+		die "Solver returned " . $resp->status_line . " / " . $resp->content;
+	}
+	
+	# Fold the result back into what we know about the groups.
+	my $variants = [];
+	my $genealogical = 0;
+	foreach my $idx ( 0 .. $#groups ) {
+		my( $calc_groups, $result ) = @{$answer->[$idx]};
+		$genealogical++ if $result;
+		my $input_group = $groups[$idx];
+		foreach my $k ( sort keys %$input_group ) {
+			my $cg = shift @$calc_groups;
+			$input_group->{$k} = $cg;
+		}
+		my $vstruct = { 
+			'genealogical' => $result,
+			'readings' => [],
+		}
+		foreach my $k ( keys %$input_group ) {
+			push( @{$vstruct->{'readings'}}, 
+				  { 'readingid' => $k, 'group' => $dg } );
+		}
+		push( @$variants, $vstruct );
+	}
+	
+	return { 'variants' => $variants, 
+			 'variant_count' => scalar @$variants,
+			 'genealogical_count' => $genealogical };
+}
+
 =head2 analyze_variant_location( $tradition, $rank, $stemma_id, @merge_relationship_types )
 
 Runs an analysis of the given tradition, at the location given in $rank, 
@@ -170,7 +299,7 @@ Returns a data structure as follows:
 
  { 	'id' => $rank,
  	'genealogical' => boolean,
- 	'readings => [ { text => $reading_text, 
+ 	'readings => [ { readingid => $reading_id, 
  					 group => [ witnesses ], 
  					 conflict => [ conflicting ], 
  					 missing => [ excluded ] }, ... ]
@@ -190,8 +319,9 @@ sub analyze_variant_location {
 	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 ] );
+	my @lacunose = $stemma->hypotheticals;
+	push( @lacunose, _symmdiff( [ $stemma->witnesses ], 
+		[ map { $_->sigil } $tradition->witnesses ] ) );
 
 	# Now group the readings
 	my( $readings, $groups ) = _useful_variant( 
@@ -209,8 +339,10 @@ sub analyze_variant_location {
     my $subgraph = {};
     my $is_conflicted;
     my $conflict = {};
+    my %reading_roots;
     my $variant_row = { 'id' => $rank, 'readings' => [] };
     # Mark each ms as in its own group, first.
+    $DB::single = 1 if $rank == 81;
     foreach my $g ( @$groups ) {
         my $gst = wit_stringify( $g );
         map { $contig->{$_} = $gst } @$g;
@@ -221,103 +353,94 @@ sub analyze_variant_location {
     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;
+        my @group_roots;
         $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. 
+            # member.  If we are genealogical this should include them all.
+            my $reachable = {}; 
             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;
+                    $part->predecessorless_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 );
+                    next unless $root;
+                    # Save this root for our group.
+                    push( @group_roots, $root );
                     # 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.
+            } else {
+            	# Dispense with the trivial case of one reading.
+            	my $wit = pop @$g;
+                @group_roots = ( $wit );
+                foreach my $v ( $part->vertices ) {
+                	$part->delete_vertex( $v ) unless $v eq $wit;
+                }
+            }
         }
         
-        # 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;
-            }
+        map { $reading_roots{$_} = 1 } @group_roots;
+        if( @group_roots > 1 ) {
+        	$conflict->{$group_readings->{$gst}} = 1;
+        	$is_conflicted = 1;
         }
+        # Paint the 'hypotheticals' with our group.
+		foreach my $wit ( $part->vertices ) {
+			if( ref( $contig->{$wit} ) ) {
+				push( @{$contig->{$wit}}, $gst );
+			} elsif( $contig->{$wit} ne $gst ) {
+				warn "How did we get here?";
+			}
+		}
         
-        # 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},
+        # Start to write the reading, and save the group subgraph.
+        my $reading = { 'readingid' => $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 };
-        }
+		# Save the relevant subgraph.
+		$subgraph->{$gst} = $part;
         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?
+	# For each of our hypothetical readings, flatten its 'contig' array if
+	# the array contains zero or one group.  If we have any unflattened arrays,
+	# we may need to run the resolution process. If the reading is already known
+	# to have a conflict, flatten the 'contig' array to nothing; we won't resolve
+	# it.
+	my @resolve;
+	foreach my $wit ( keys %$contig ) {
+		next unless ref( $contig->{$wit} );
+		if( @{$contig->{$wit}} > 1 ) {
+			if( $is_conflicted ) {
+				$contig->{$wit} = '';  # We aren't going to decide.
+			} else {
+				push( @resolve, $wit );			
+			}
+		} else {
+			my $gst = pop @{$contig->{$wit}};
+			$contig->{$wit} = $gst || '';
+		}
+	}
+	
+    if( @resolve ) {
         my $still_contig = {};
         foreach my $h ( @resolve ) {
             # For each of the hypothetical readings with more than one possibility,
@@ -327,54 +450,120 @@ sub analyze_variant_location {
             # 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'};
+                my $gpart = $subgraph->{$gst}->copy();
+                # If we have come this far, there is only one root and everything
+                # is reachable from it.
+                my( $root ) = $gpart->predecessorless_vertices;    
+                my $reachable = {};
+                map { $reachable->{$_} = 1 } $gpart->vertices;
+
+                # Try deleting the hypothetical node. 
                 $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.
-                }
-            }
-        }
+                if( $h eq $root ) {
+                	# See if we still have a single root.
+                	my @roots = $gpart->predecessorless_vertices;
+                	warn "This shouldn't have happened" unless @roots;
+                	if( @roots > 1 ) {
+                		# $h is needed by this group.
+                		if( exists( $still_contig->{$h} ) ) {
+                			# Conflict!
+                			$conflict->{$group_readings->{$gst}} = 1;
+                			$still_contig->{$h} = '';
+                		} else {
+                			$still_contig->{$h} = $gst;
+                		}
+                	}
+                } else {
+                	# $h is somewhere in the middle. See if everything
+                	# else can still be reached from the root.
+					my %still_reachable = ( $root => 1 );
+					map { $still_reachable{$_} = 1 }
+						$gpart->all_successors( $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}} = 1;
+								$still_contig->{$h} = '';
+							} else {
+								$still_contig->{$h} = $gst;
+							}
+							last;
+						} # else we don't need $h in this group.
+					} # end foreach $v
+				} # endif $h eq $root
+            } # end foreach $gst
+        } # end foreach $h
         
-        # 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 we have some hypothetical vertices in $still_contig that are the 
+        # "real" group memberships.  Replace these in $contig.
+		foreach my $v ( keys %$contig ) {
+			next unless ref $contig->{$v};
+			$contig->{$v} = $still_contig->{$v};
+		}
+    } # end if @resolve
+    
+    # Now that we have all the node group memberships, calculate followed/
+    # non-followed/unknown values for each reading.  Also figure out the
+    # reading's evident parent(s).
+    foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
+        my $gst = $rdghash->{'group'};
+        my $part = $subgraph->{$gst};
+        my @roots = $part->predecessorless_vertices;
+        $rdghash->{'independent_occurrence'} = scalar @roots;
+        $rdghash->{'followed'} = scalar( $part->vertices ) - scalar( @roots );
+        # Find the parent readings, if any, of this reading.
+        my %rdgparents;
+        foreach my $wit ( @roots ) {
+        	# Look in the main stemma to find this witness's extant or known-reading
+        	# immediate ancestor(s), and look up the reading that each ancestor olds.
+			my @check = $graph->predecessors( $wit );
+			while( @check ) {
+				my @next;
+				foreach my $wparent( @check ) {
+					my $pgroup = $contig->{$wparent};
+					if( $pgroup ) {
+						$rdgparents{$group_readings->{$pgroup}} = 1;
+					} else {
+						push( @next, $graph->predecessors( $wparent ) );
+					}
+				}
+				@check = @next;
+			}
+		}
+		$rdghash->{'reading_parents'} = [ keys %rdgparents ];
+		
+		# Find the number of times this reading was altered, and the number of
+		# times we're not sure.
+		my( %nofollow, %unknownfollow );
+		foreach my $wit ( $part->vertices ) {
+			foreach my $wchild ( $graph->successors( $wit ) ) {
+				next if $part->has_vertex( $wchild );
+				if( $reading_roots{$wchild} && $contig->{$wchild} ) {
+					# It definitely changed here.
+					$nofollow{$wchild} = 1;
+				} elsif( !($contig->{$wchild}) ) {
+					# The child is a hypothetical node not definitely in
+					# any group. Answer is unknown.
+					$unknownfollow{$wchild} = 1;
+				} # else it's a non-root node in a known group, and therefore
+				  # is presumed to have its reading from its group, not this link.
+			}
+		}
+		$rdghash->{'not_followed'} = keys %nofollow;
+		$rdghash->{'follow_unknown'} = keys %unknownfollow;
     }
-            
+    
     # 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 );
+    foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
+        $rdghash->{'conflict'} = $conflict->{$rdghash->{'readingid'}};
+        my @members = grep { $contig->{$_} eq $rdghash->{'group'} } keys %$contig;
+        $rdghash->{'group'} = wit_stringify( \@members );
     }
     
     $variant_row->{'genealogical'} = !( keys %$conflict );
@@ -392,13 +581,14 @@ sub _prune_subtree {
             $tree->successorless_vertices;
     }
     # Then delete a hypothetical root with only one successor, moving the
-    # root to the child.
+    # root to the first child that has no other predecessors.
     while( $tree->successors( $root ) == 1 && ref $contighash->{$root} ) {
         my @nextroot = $tree->successors( $root );
         $tree->delete_vertex( $root );
-        $root = $nextroot[0];
+        ( $root ) = grep { $tree->is_predecessorless_vertex( $_ ) } @nextroot;
     }
     # The tree has been modified in place, but we need to know the new root.
+    $root = undef unless $root && $tree->has_vertex( $root );
     return $root;
 }
 # Add the variant, subject to a.c. representation logic.
@@ -484,20 +674,13 @@ sub _add_to_witlist {
 	}
 }
 
-sub _set {
-	my( $op, $lista, $listb ) = @_;
+sub _symmdiff {
+	my( $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;
-	}
+	my @set = grep { $union{$_} == 1 } keys %union;
 	return map { $scalars{$_} } @set;
 }