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.
# 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};
# }
# 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 } ]
projects / scpubgit/stemmatology.git / blobdiff