sub new {
my( $class, $args ) = @_;
my $self = {};
- # Our object needs to have a stemma graph and a variant table.
- my( $svg, $variants ) = run_analysis( $args->{'file'}, $args->{'stemmadot'} );
- $self->{'svg'} = $svg;
- $self->{'variants'} = $variants;
-
bless( $self, $class );
+ $self->{'data'} = [];
+ foreach my $t ( @{$args->{'traditions'}} ) {
+ $self->run_analysis( $t->{'file'}, $t->{'stemmadot'} );
+ }
return $self;
}
sub run_analysis {
- my( $file, $stemmadot ) = @_;
+ my( $self, $file, $stemmadot ) = @_;
# What we will return
my $svg;
my $variants = [];
+ my $data = {};
- # Read in the file and stemma
- my @lines;
- open( INFILE, "$file" ) or die "Could not read $file";
- binmode INFILE, ':utf8';
- @lines = <INFILE>;
- close INFILE;
-
+ # Read in the file and stemma
my $tradition = Text::Tradition->new(
- 'Self' => join( '', @lines ),
+ '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;
- ### DIRTY HACK
- $svg =~ s/transform=\"scale\(1 1\)/transform=\"scale\(0.7 0.7\)/;
+ $svg = $stemma->as_svg( { size => "8,7.5" } );;
+ $data->{'svg'} = $svg;
# 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 = $tradition->collation->make_alignment_table( 'refs' );
+ 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 $html_data = [];
- my $total = 0; # Keep track of the total number of variant locations
+ my ( $total, $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;
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];
- $rank = $rdg->rank if $rdg && !$rank; # Make a note of our rank
my $rdg_text = '(omitted)'; # Initialize in case of empty reading
if( $rdg ) {
- $rdg_text = $rdg->is_lacuna ? undef : $rdg->text; # Don't count lacunae
+ 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
my( $groups, $readings ) = useful_variant( $rdg_wits );
next unless $groups && $readings;
- # Initialize the data structure for the row that we will return
- my $variant_row = {'id' => $rank, 'readings' => [] };
# Keep track of our widest row
$html_columns = scalar @$groups if scalar @$groups > $html_columns;
# For all the groups with more than one member, collect the list of all
# contiguous vertices needed to connect them.
# TODO: deal with a.c. reading logic
- my $sc = analyze_variant_location( $group_readings, $groups, $stemma->apsp );
- $variant_row->{'genealogical'} = keys %$sc ? 1 : undef;
- foreach my $grp ( sort keys %$group_readings ) {
- my $rdg = $group_readings->{$grp};
- push( @{$variant_row->{'readings'}}, { 'text' => $rdg, 'group' => $grp } );
- }
-
+ $DB::single = 1 if $rank == 25;
+ my $variant_row = analyze_variant_location( $group_readings, $groups,
+ $stemma->graph, $lacunose );
+ $variant_row->{'id'} = $rank;
+ $genealogical++ if $variant_row->{'genealogical'};
+ $conflicts += grep { $_->{'conflict'} } @{$variant_row->{'readings'}};
+
# Now run the same analysis given the calculated distance tree(s).
-# foreach my $tree ( 0 .. $#{$stemma->distance_trees} ) {
-# my $dc = analyze_variant_location( $group_readings, $groups,
-# $stemma->distance_apsps->[$tree] );
-# foreach my $rdg ( keys %$dc ) {
-# my $var = $dc->{$rdg};
-# }
-# }
-
+# my @trees = @{$stemma->distance_trees};
+# if( @trees ) {
+# foreach my $tree ( 0 .. $#trees ) {
+# my $dc = analyze_variant_location( $group_readings, $groups, $tree );
+# foreach my $rdg ( keys %$dc ) {
+# my $var = $dc->{$rdg};
+# # TODO Do something with this
+# }
+# }
+# }
+
# Record that we used this variant in an analysis
push( @$variants, $variant_row );
}
- # Go through our variant rows and add the number of empty columns we need.
+ # Go through our variant rows, 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'}};
$row->{'empty'} = $empty;
}
- return( $svg, $variants );
+ # Populate self with our analysis data.
+ $data->{'variants'} = $variants;
+ $data->{'variant_count'} = $total;
+ $data->{'conflict_count'} = $conflicts;
+ $data->{'genealogical_count'} = $genealogical;
+ push( @{$self->{'data'}}, $data );
}
+# variant_row -> genealogical
+# -> readings [ { text, group, conflict, missing } ]
+
sub analyze_variant_location {
- my( $group_readings, $groups, $apsp ) = @_;
+ my( $group_readings, $groups, $graph, $lacunose ) = @_;
my %contig;
my $conflict = {};
+ my %missing;
+ map { $missing{$_} = 1 } @$lacunose;
+ my $variant_row = { 'readings' => [] };
+ # Mark each ms as in its own group, first.
+ foreach my $g ( @$groups ) {
+ my $gst = wit_stringify( $g );
+ map { $contig{$_} = $gst } @$g;
+ }
foreach my $g ( sort { scalar @$b <=> scalar @$a } @$groups ) {
- my @members = @$g;
my $gst = wit_stringify( $g );
- map { $contig{$_} = $gst } @members; # The witnesses need themselves to be
- # in their collection.
- next unless @members > 1;
- my $curr = pop @members;
- foreach my $m ( @members ) {
- foreach my $v ( $apsp->path_vertices( $curr, $m ) ) {
- $contig{$v} = $gst unless exists $contig{$v};
- next if $contig{$v} eq $gst;
- # print STDERR "Conflict at $v between group $gst and group "
- # . $contig{$v} . "\n";
- # Record what is conflicting.
- $conflict->{$group_readings->{$gst}} = $group_readings->{$contig{$v}};
+ # Copy the graph, and delete all non-members from the new graph.
+ my $part = $graph->undirected_copy;
+ map { $part->delete_vertex( $_ )
+ if $contig{$_} && $contig{$_} ne $gst } $graph->vertices;
+ # Now all the members of the group should still be reachable
+ # from the first member.
+ my %reachable = ( $g->[0] => 1 );
+ map { $reachable{$_} = 1 } $part->all_reachable( $g->[0] );
+
+ # ...and none of these nodes should be marked as being in another
+ # group.
+ foreach ( keys %reachable ) {
+ if( $contig{$_} && $contig{$_} ne $gst ) {
+ $conflict->{$group_readings->{$gst}} = $group_readings->{$contig{$_}};
+ } else {
+ $contig{$_} = $gst;
}
}
+ # None of the unreachable nodes should be in our group either.
+ foreach ( $part->vertices ) {
+ next if $reachable{$_};
+ $conflict->{$group_readings->{$gst}} = $group_readings->{$gst}
+ if $contig{$_} && $contig{$_} eq $gst;
+ }
+
+ # Write the reading.
+ my $reading = { 'text' => $group_readings->{$gst},
+ 'missing' => wit_stringify( $lacunose ),
+ 'conflict' => exists( $conflict->{$group_readings->{$gst}} ) };
+ if( $reading->{'conflict'} ) {
+ $reading->{'group'} = $gst;
+ } else {
+ my @all_vertices = grep { !$missing{$_} } keys %reachable;
+ $reading->{'group'} = wit_stringify( \@all_vertices );
+ }
+ push( @{$variant_row->{'readings'}}, $reading );
}
- return $conflict;
+ $variant_row->{'genealogical'} = !( keys %$conflict );
+ return $variant_row;
}
# Add the variant, subject to a.c. representation logic.
projects / scpubgit/stemmatology.git / blobdiff