X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FAnalysis.pm;h=910f9947e1f368ef7f76398cf7c197b0aab28b52;hb=b979e2e269da9877011d671af5b2857f2189fc6e;hp=7eaee5189077cc00a43a2dc089154ccfe6d17ba5;hpb=231d71fcb0aa140014259130d9f4ef4aafedafda;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Analysis.pm b/lib/Text/Tradition/Analysis.pm
index 7eaee51..910f994 100644
--- a/lib/Text/Tradition/Analysis.pm
+++ b/lib/Text/Tradition/Analysis.pm
@@ -2,96 +2,44 @@ package Text::Tradition::Analysis;
 
 use strict;
 use warnings;
+use Benchmark;
+use Exporter 'import';
 use Text::Tradition;
 use Text::Tradition::Stemma;
 
-sub new {
-	my( $class, $args ) = @_;
-	my $self = {};
-	bless( $self, $class );	
-	$self->{'data'} = [];
-	foreach my $t ( @{$args->{'traditions'}} ) {
-	    $self->run_analysis( $t->{'file'}, $t->{'stemmadot'} );
-	}
-	return $self;
-}
+use vars qw/ @EXPORT_OK /;
+@EXPORT_OK = qw/ run_analysis group_variants analyze_variant_location wit_stringify /;
 
 sub run_analysis {
-	my( $self, $file, $stemmadot ) = @_;
+	my( $tradition ) = @_;
 	# What we will return
-	my $svg;
 	my $variants = [];
 	my $data = {};
 	
-	# Read in the file and stemma	
-	my $tradition = Text::Tradition->new( 
-		'input'  => 'Self',
-		'file'   => $file,
-		'linear' => 1,
-		);
-	$data->{'title'} = $tradition->name;
-	
-	my $stemma = Text::Tradition::Stemma->new(
-		'collation' => $tradition->collation,
-		'dot' => $stemmadot,
-		);
-	# We will return the stemma picture
-	$svg = $stemma->as_svg( { size => "8,7.5" } );;
-	$data->{'svg'} = $svg;
-	
+	# We need a stemma in order to run this...
+	unless( $tradition->stemma_count ) {
+		warn "Tradition '" . $tradition->name . "' has no stemma to analyze";
+		return undef;
+	}
+	my $stemma = $tradition->stemma(0); # TODO allow multiple
+		
 	# We have the collation, so get the alignment table with witnesses in rows.
 	# Also return the reading objects in the table, rather than just the words.
 	my $wits = {};
 	map { $wits->{$_} = 1 } $stemma->witnesses;
-	my $all_wits_table = $tradition->collation->make_alignment_table( 'refs', $wits );
-	
 	# For each column in the alignment table, we want to see if the existing
-	# groupings of witnesses match our stemma hypothesis. We also want, at the
-	# end, to produce an HTML table with all the variants.
-	my $html_columns = 0;
-	my ( $total, $genealogical, $conflicts ) = ( 0, 0, 0 );
+	# groupings of witnesses match our stemma hypothesis. We also need to keep
+	# track of the maximum number of variants at any one location.
+	my $max_variants = 0;
+	my ( $genealogical, $conflicts ) = ( 0, 0, 0 );
 	
-	# Strip the list of sigla and save it for correlation to the readings.
-	my $col_wits = shift @$all_wits_table;
-	
-	# We will return a data structure, an array for each row that looks like:
-	# { id = X, genealogical = Y, readings = [ text = X, group = Y], empty = N }
-	foreach my $i ( 0 .. $#$all_wits_table ) {
-		# For each column in the table, group the readings by witness.
-		my $rdg_wits = {};
-		my $col_rdgs = shift @$all_wits_table;
-		my $rank;
-		my $lacunose = [];
-		foreach my $j ( 0 .. $#{$col_rdgs} ) {
-			my $rdg = $col_rdgs->[$j];
-			my $rdg_text = '(omitted)';  # Initialize in case of empty reading
-			if( $rdg ) {
-			    if( $rdg->is_lacuna ) {
-			        $rdg_text = undef;   # Don't count lacunae
-			        push( @$lacunose, $col_wits->[$j] );
-			    } else {
-    				$rdg_text = $rdg->text; 
-				    # Get the rank from any real reading; they should be identical.
-				    $rank = $rdg->rank;
-				}
-			}
-			if( defined $rdg_text ) {
-				# Initialize the witness array if we haven't got one yet
-				$rdg_wits->{$rdg_text} = [] unless $rdg_wits->{$rdg_text};
-				# Add the relevant witness, subject to a.c. logic
-				add_variant_wit( $rdg_wits->{$rdg_text}, $col_wits->[$j],
-					$tradition->collation->ac_label );
-			}
-		}
+    my $variant_groups = group_variants( $tradition->collation, $wits );
+    foreach my $rank ( 0 .. $#{$variant_groups} ) {
+        my $groups = $variant_groups->[$rank]->{'groups'};
+        my $readings = $variant_groups->[$rank]->{'readings'};
+        my $lacunose = $variant_groups->[$rank]->{'lacunose'};
 		
-		# See if this column has any potentially genealogical variants.
-		# If not, skip to the next.
-		$total++ unless scalar keys %$rdg_wits == 1;
-		my( $groups, $readings ) = useful_variant( $rdg_wits );
-		next unless $groups && $readings;  
-		
-		# Keep track of our widest row
-		$html_columns = scalar @$groups if scalar @$groups > $html_columns;
+		$max_variants = scalar @$groups if scalar @$groups > $max_variants;
 		
 		# We can already look up witnesses for a reading; we also want to look
 		# up readings for a given witness.
@@ -102,12 +50,11 @@ sub run_analysis {
 		
 		# For all the groups with more than one member, collect the list of all
 		# contiguous vertices needed to connect them.
-		$DB::single = 1;
-		my $variant_row = analyze_variant_location( $group_readings, $groups, 
+		my $variant_loc = analyze_variant_location( $group_readings, $groups, 
 		    $stemma->graph, $lacunose );
-		$variant_row->{'id'} = $rank;
-		$genealogical++ if $variant_row->{'genealogical'};
-		$conflicts += grep { $_->{'conflict'} } @{$variant_row->{'readings'}};
+		$variant_loc->{'id'} = $rank;
+		$genealogical++ if $variant_loc->{'genealogical'};
+		$conflicts += grep { $_->{'conflict'} } @{$variant_loc->{'readings'}};
 
 		# Now run the same analysis given the calculated distance tree(s).
 # 		my @trees = @{$stemma->distance_trees};
@@ -122,24 +69,75 @@ sub run_analysis {
 # 	    }
 
 		# Record that we used this variant in an analysis
-		push( @$variants, $variant_row );
+		push( @$variants, $variant_loc );
 	}
-	
-	# Go through our variant rows, after we have seen all of them once,
+
+	# Go through our variant locations, after we have seen all of them once,
 	# and add the number of empty columns needed by each.
 	foreach my $row ( @$variants ) {
-		my $empty = $html_columns - scalar @{$row->{'readings'}};
+		my $empty = $max_variants - scalar @{$row->{'readings'}};
 		$row->{'empty'} = $empty;
 	}
 	
-	# Populate self with our analysis data.
 	$data->{'variants'} = $variants;
-	$data->{'variant_count'} = $total;
+	$data->{'variant_count'} = $tradition->collation->end->rank - 1;
 	$data->{'conflict_count'} = $conflicts;
 	$data->{'genealogical_count'} = $genealogical;
-	push( @{$self->{'data'}}, $data );
+	return $data;
 }
 
+sub group_variants {
+	my( $c, $wits ) = @_;
+	my $variant_groups = [];
+	
+	# We have the collation, so get the alignment table with witnesses in rows.
+	# Also return the reading objects in the table, rather than just the words.
+	my $all_wits_table = $c->make_alignment_table( 'refs', $wits );
+	# Strip the list of sigla and save it for correlation to the readings.
+	my @table_wits = map { $_->{'witness'} } @{$all_wits_table->{'alignment'}};
+	# Any witness in the stemma that has no row should be noted.
+    foreach ( @table_wits ) {
+        $wits->{$_}++; # Witnesses present in table and stemma now have value 2.
+    }
+    my @not_collated = grep { $wits->{$_} == 1 } keys %$wits;
+	foreach my $i ( 0 .. $all_wits_table->{'length'} - 1 ) {
+		# For each column in the table, group the readings by witness.
+		my $rdg_wits = {};
+		my @col_rdgs = map { $_->{tokens}->[$i] } @{$all_wits_table->{'alignment'}};
+		my $lacunose = [ @not_collated ];
+		foreach my $j ( 0 .. $#col_rdgs ) {
+			my $rdg = $col_rdgs[$j];
+			my $rdg_text = '(omitted)';  # Initialize in case of empty reading
+			if( $rdg ) {
+			    if( $rdg->{'t'}->is_lacuna ) {
+			        $rdg_text = undef;   # Don't count lacunae
+			        push( @$lacunose, $table_wits[$j] );
+			    } else {
+    				$rdg_text = $rdg->{'t'}->text; 
+				}
+			}
+			if( defined $rdg_text ) {
+				# Initialize the witness array if we haven't got one yet
+				$rdg_wits->{$rdg_text} = [] unless $rdg_wits->{$rdg_text};
+				# Add the relevant witness, subject to a.c. logic
+				add_variant_wit( $rdg_wits->{$rdg_text}, $table_wits[$j],
+					$c->ac_label );
+			}
+		}
+		
+		# See if this column has any potentially genealogical variants.
+		# If not, skip to the next.
+		my( $groups, $readings ) = useful_variant( $rdg_wits );
+		next unless $groups && $readings;  
+
+		push( @$variant_groups, 
+		    { 'groups' => $groups, 'readings' => $readings, 'lacunose' => $lacunose } );
+	}
+	return $variant_groups;
+}
+
+
+
 # variant_row -> genealogical
 #             -> readings [ { text, group, conflict, missing } ]