X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FAnalysis.pm;h=fda51376077c9e67781e1c5e134c203704fd706a;hb=f2fec47dc44816775c844e8b50cef03b12b69dae;hp=8dcf25da013c9ef9f21cc4120e4ca378403bc4b9;hpb=adc08836a8f9e1bff3b372c498ac1dcda1100894;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Analysis.pm b/lib/Text/Tradition/Analysis.pm
index 8dcf25d..fda5137 100644
--- a/lib/Text/Tradition/Analysis.pm
+++ b/lib/Text/Tradition/Analysis.pm
@@ -56,6 +56,8 @@ is 0 (i.e. the first).
 =item * merge_types - Specify a list of relationship types, where related readings 
 should be treated as identical for the purposes of analysis.
 
+=item * exclude_type1 - Exclude those ranks whose groupings have only type-1 variants.
+
 =back
 
 =begin testing
@@ -107,8 +109,7 @@ foreach my $row ( @{$data->{'variants'}} ) {
 	unless( exists $expected_genealogical{$row->{'id'}} ) {
 		$expected_genealogical{$row->{'id'}} = 1;
 	}
-	my $gen_bool = $row->{'genealogical'} ? 1 : 0;
-	is( $gen_bool, $expected_genealogical{$row->{'id'}}, 
+	is( $row->{'genealogical'}, $expected_genealogical{$row->{'id'}}, 
 		"Got correct genealogical flag for row " . $row->{'id'} );
 }
 is( $data->{'variant_count'}, 58, "Got right total variant number" );
@@ -151,7 +152,13 @@ sub run_analysis {
 	my %lacunae;
 	foreach my $rank ( @ranks ) {
 		my $missing = [ @lacunose ];
-		push( @groups, group_variants( $tradition, $rank, $missing, \@collapse ) );
+		my $rankgroup = group_variants( $tradition, $rank, $missing, \@collapse );
+		if( $opts{'exclude_type1'} ) {
+			# Check to see whether this is a "useful" group.
+			my( $rdgs, $grps ) = _useful_variant( $rankgroup );
+			next unless @$rdgs;
+		}
+		push( @groups, $rankgroup );
 		$lacunae{$rank} = $missing;
 	}
 	$DB::single = 1;
@@ -188,8 +195,8 @@ 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].
+Returns a hash $group_readings where $rdg is attested by the witnesses listed 
+in $group_readings->{$rdg}.
 
 =cut
 
@@ -263,7 +270,7 @@ sub solve_variants {
 	my $groupings = [];
 	foreach my $ghash ( @groups ) {
 		my @grouping;
-		foreach my $k ( sort keys %$ghash ) {
+		foreach my $k ( keys %$ghash ) {
 			push( @grouping, $ghash->{$k} );
 		}
 		push( @$groupings, \@grouping );
@@ -279,8 +286,10 @@ sub solve_variants {
 						  'Content' => $json );
 						  
 	my $answer;
+	my $used_idp;
 	if( $resp->is_success ) {
 		$answer = _desanitize_names( decode_json( $resp->content ), $witness_map );
+		$used_idp = 1;
 	} else {
 		# Fall back to the old method.
 		warn "IDP solver returned " . $resp->status_line . " / " . $resp->content
@@ -293,7 +302,18 @@ sub solve_variants {
 	my $genealogical = 0;
 	foreach my $idx ( 0 .. $#groups ) {
 		my( $calc_groups, $result ) = @{$answer->[$idx]};
-		$genealogical++ if $result;
+		if( $result ) {
+			$genealogical++;
+			# Prune the calculated groups, in case the IDP solver failed to.
+			if( $used_idp ) {
+				my @pruned_groups;
+				foreach my $cg ( @$calc_groups ) {
+					my @pg = _prune_group( $cg, $stemma );
+					push( @pruned_groups, \@pg );
+				}
+				$calc_groups = \@pruned_groups;
+			}
+		}
 		my $input_group = $groups[$idx];
 		foreach my $k ( sort keys %$input_group ) {
 			my $cg = shift @$calc_groups;
@@ -689,6 +709,24 @@ sub _solve_variant_location {
     return $variant_row;
 }
 
+sub _prune_group {
+	my( $group, $stemma ) = @_;
+	# Get these into a form prune_subtree will recognize. Make a "contighash"
+	my $hypohash = {};
+	map { $hypohash->{$_} = 1 } @$group;
+	# ...with reference values for hypotheticals.
+	map { $hypohash->{$_} = [] } $stemma->hypotheticals;
+	# Make our subgraph
+	my $subgraph = $stemma->graph->copy;
+	map { $subgraph->delete_vertex( $_ ) unless exists $hypohash->{$_} }
+		$subgraph->vertices;
+	# ...and find the root.
+	my( $root ) = $subgraph->predecessorless_vertices;
+	# Now prune and return the remaining vertices.
+	_prune_subtree( $subgraph, $root, $hypohash );
+	return $subgraph->vertices;
+}
+
 sub _prune_subtree {
     my( $tree, $root, $contighash ) = @_;
     # First, delete hypothetical leaves / orphans until there are none left.