use IPC::Run qw( run binary );
use Text::CSV_XS;
use Text::Tradition::Collation::Reading;
+use Text::Tradition::Collation::RelationshipStore;
+use Text::Tradition::Error;
use XML::LibXML;
+use XML::LibXML::XPathContext;
use Moose;
has 'sequence' => (
has 'relations' => (
is => 'ro',
- isa => 'Graph',
- default => sub { Graph->new( undirected => 1 ) },
- handles => {
- relationships => 'edges',
- },
+ isa => 'Text::Tradition::Collation::RelationshipStore',
+ handles => {
+ relationships => 'relationships',
+ related_readings => 'related_readings',
+ },
+ writer => '_set_relations',
);
has 'tradition' => (
isa => 'Bool',
default => 1,
);
-
+
has 'ac_label' => (
is => 'rw',
isa => 'Str',
weak_ref => 1,
);
-# The collation can be created two ways:
-# 1. Collate a set of witnesses (with CollateX I guess) and process
-# the results as in 2.
-# 2. Read a pre-prepared collation in one of a variety of formats,
-# and make the graph from that.
-
-# The graph itself will (for now) be immutable, and the positions
-# within the graph will also be immutable. We need to calculate those
-# positions upon graph construction. The equivalences between graph
-# nodes will be mutable, entirely determined by the user (or possibly
-# by some semantic pre-processing provided by the user.) So the
-# constructor should just make an empty equivalences object. The
-# constructor will also need to make the witness objects, if we didn't
-# come through option 1.
+=head1 NAME
+
+Text::Tradition::Collation - a software model for a text collation
+
+=head1 SYNOPSIS
+
+ use Text::Tradition;
+ my $t = Text::Tradition->new(
+ 'name' => 'this is a text',
+ 'input' => 'TEI',
+ 'file' => '/path/to/tei_parallel_seg_file.xml' );
+
+ my $c = $t->collation;
+ my @readings = $c->readings;
+ my @paths = $c->paths;
+ my @relationships = $c->relationships;
+
+ my $svg_variant_graph = $t->collation->as_svg();
+
+=head1 DESCRIPTION
+
+Text::Tradition is a library for representation and analysis of collated
+texts, particularly medieval ones. The Collation is the central feature of
+a Tradition, where the text, its sequence of readings, and its relationships
+between readings are actually kept.
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+The constructor. Takes a hash or hashref of the following arguments:
+
+=over
+
+=item * tradition - The Text::Tradition object to which the collation
+belongs. Required.
+
+=item * linear - Whether the collation should be linear; that is, whether
+transposed readings should be treated as two linked readings rather than one,
+and therefore whether the collation graph is acyclic. Defaults to true.
+
+=item * baselabel - The default label for the path taken by a base text
+(if any). Defaults to 'base text'.
+
+=item * wit_list_separator - The string to join a list of witnesses for
+purposes of making labels in display graphs. Defaults to ', '.
+
+=item * ac_label - The extra label to tack onto a witness sigil when
+representing another layer of path for the given witness - that is, when
+a text has more than one possible reading due to scribal corrections or
+the like. Defaults to ' (a.c.)'.
+
+=back
+
+=head1 ACCESSORS
+
+=head2 tradition
+
+=head2 linear
+
+=head2 wit_list_separator
+
+=head2 baselabel
+
+=head2 ac_label
+
+Simple accessors for collation attributes.
+
+=head2 start
+
+The meta-reading at the start of every witness path.
+
+=head2 end
+
+The meta-reading at the end of every witness path.
+
+=head2 readings
+
+Returns all Reading objects in the graph.
+
+=head2 reading( $id )
+
+Returns the Reading object corresponding to the given ID.
+
+=head2 add_reading( $reading_args )
+
+Adds a new reading object to the collation.
+See L<Text::Tradition::Collation::Reading> for the available arguments.
+
+=head2 del_reading( $object_or_id )
+
+Removes the given reading from the collation, implicitly removing its
+paths and relationships.
+
+=head2 merge_readings( $main, $second )
+
+Merges the $second reading into the $main one.
+The arguments may be either readings or reading IDs.
+
+=head2 has_reading( $id )
+
+Predicate to see whether a given reading ID is in the graph.
+
+=head2 reading_witnesses( $object_or_id )
+
+Returns a list of sigils whose witnesses contain the reading.
+
+=head2 paths
+
+Returns all reading paths within the document - that is, all edges in the
+collation graph. Each path is an arrayref of [ $source, $target ] reading IDs.
+
+=head2 add_path( $source, $target, $sigil )
+
+Links the given readings in the collation in sequence, under the given witness
+sigil. The readings may be specified by object or ID.
+
+=head2 del_path( $source, $target, $sigil )
+
+Links the given readings in the collation in sequence, under the given witness
+sigil. The readings may be specified by object or ID.
+
+=head2 has_path( $source, $target );
+
+Returns true if the two readings are linked in sequence in any witness.
+The readings may be specified by object or ID.
+
+=head2 relationships
+
+Returns all Relationship objects in the collation.
+
+=head2 add_relationship( $reading, $other_reading, $options )
+
+Adds a new relationship of the type given in $options between the two readings,
+which may be specified by object or ID. Returns a value of ( $status, @vectors)
+where $status is true on success, and @vectors is a list of relationship edges
+that were ultimately added.
+See L<Text::Tradition::Collation::Relationship> for the available options.
+
+=cut
sub BUILD {
my $self = shift;
+ $self->_set_relations( Text::Tradition::Collation::RelationshipStore->new( 'collation' => $self ) );
$self->_set_start( $self->add_reading( { 'collation' => $self, 'is_start' => 1 } ) );
$self->_set_end( $self->add_reading( { 'collation' => $self, 'is_end' => 1 } ) );
}
}
# First check to see if a reading with this ID exists.
if( $self->reading( $reading->id ) ) {
- warn "Collation already has a reading with id " . $reading->id;
- return undef;
+ throw( "Collation already has a reading with id " . $reading->id );
}
$self->_add_reading( $reading->id => $reading );
# Once the reading has been added, put it in both graphs.
$self->sequence->add_vertex( $reading->id );
- $self->relations->add_vertex( $reading->id );
+ $self->relations->add_reading( $reading->id );
return $reading;
};
}
# Remove the reading from the graphs.
$self->sequence->delete_vertex( $arg );
- $self->relations->delete_vertex( $arg );
+ $self->relations->delete_reading( $arg );
# Carry on.
$self->$orig( $arg );
@wits{keys %$fwits} = values %$fwits;
$self->sequence->set_edge_attributes( @vector, \%wits );
}
- foreach my $rel ( $self->relations->edges_at( $deleted ) ) {
- my @vector = ( $kept );
- push( @vector, $rel->[0] eq $deleted ? $rel->[1] : $rel->[0] );
- next if $vector[0] eq $vector[1]; # Don't add a self loop
- # Is there a relationship here already? If so, keep it.
- # TODO Warn about conflicting relationships
- next if $self->relations->has_edge( @vector );
- # If not, adopt the relationship that would be deleted.
- $self->relations->add_edge( @vector );
- my $attr = $self->relations->get_edge_attributes( @$rel );
- $self->relations->set_edge_attributes( @vector, $attr );
- }
+ $self->relations->merge_readings( $kept, $deleted, $combine_char );
# Do the deletion deed.
if( $combine_char ) {
return( $first, $second, $arg );
}
+# Helper function for manipulating the graph.
+sub _objectify_args {
+ my( $self, $first, $second, $arg ) = @_;
+ $first = $self->reading( $first )
+ unless ref( $first ) eq 'Text::Tradition::Collation::Reading';
+ $second = $self->reading( $second )
+ unless ref( $second ) eq 'Text::Tradition::Collation::Reading';
+ return( $first, $second, $arg );
+}
### Path logic
sub add_path {
return $self->sequence->has_edge_attribute( $source, $target, $wit );
}
-### Relationship logic
-
-=head2 add_relationship( $reading1, $reading2, $definition )
+=head2 clear_witness( @sigil_list )
-Adds the specified relationship between the two readings. A relationship
-is transitive (i.e. undirected), and must have the following attributes
-specified in the hashref $definition:
-
-=over 4
-
-=item * type - Can be one of spelling, orthographic, grammatical, meaning, lexical, collated, repetition, transposition. All but the last two are only valid relationships between readings that occur at the same point in the text.
-
-=item * non_correctable - (Optional) True if the reading would not have been corrected independently.
-
-=item * non_independent - (Optional) True if the variant is unlikely to have occurred independently in unrelated witnesses.
-
-=item * global - (Optional) A meta-attribute, to set the same relationship between readings with the same text whenever they occur in the same place.
-
-=back
+Clear the given witnesses out of the collation entirely, removing references
+to them in paths, and removing readings that belong only to them. Should only
+be called via $tradition->del_witness.
=cut
-# Wouldn't it be lovely if edges could be objects, and all this type checking
-# and attribute management could be done via Moose?
+sub clear_witness {
+ my( $self, @sigils ) = @_;
-sub add_relationship {
- my $self = shift;
- my( $source, $target, $options ) = $self->_stringify_args( @_ );
-
- # Check the options
- if( !defined $options->{'type'} ||
- $options->{'type'} !~ /^(spelling|orthographic|grammatical|meaning|lexical|collated|repetition|transposition)$/i ) {
- my $t = $options->{'type'} ? $options->{'type'} : '';
- return( undef, "Invalid or missing type " . $options->{'type'} );
- }
- unless ( $options->{'type'} =~ /^(repetition|transposition)$/ ) {
- $options->{'colocated'} = 1;
+ # Clear the witness(es) out of the paths
+ foreach my $e ( $self->paths ) {
+ foreach my $sig ( @sigils ) {
+ $self->del_path( $e, $sig );
+ }
}
- # Make sure there is not another relationship between these two
- # readings already
- if( $self->relations->has_edge( $source, $target ) ) {
- return ( undef, "Relationship already exists between these readings" );
- }
- if( !$self->relationship_valid( $source, $target, $options->{'type'} ) ) {
- return ( undef, 'Relationship creates witness loop' );
- }
-
- my @vector = ( $source, $target );
- $self->relations->add_edge( @vector );
- $self->relations->set_edge_attributes( @vector, $options );
-
- # TODO Handle global relationship setting
-
- return( 1, @vector );
-}
-
-sub relationship_valid {
- my( $self, $source, $target, $rel ) = @_;
- if( $rel eq 'repetition' ) {
- return 1;
- } elsif ( $rel eq 'transposition' ) {
- # Check that the two readings do not appear in the same witness.
- my %seen_wits;
- map { $seen_wits{$_} = 1 } $self->reading_witnesses( $source );
- foreach my $w ( $self->reading_witnesses( $target ) ) {
- return 0 if $seen_wits{$w};
+ # Clear out the newly unused readings
+ foreach my $r ( $self->readings ) {
+ unless( $self->reading_witnesses( $r ) ) {
+ $self->del_reading( $r );
}
- return 1;
- } else {
- # Check that linking the source and target in a relationship won't lead
- # to a path loop for any witness. First make a lookup table of all the
- # readings related to either the source or the target.
- my @proposed_related = ( $source, $target );
- push( @proposed_related, $self->related_readings( $source, 'colocated' ) );
- push( @proposed_related, $self->related_readings( $target, 'colocated' ) );
- my %pr_ids;
- map { $pr_ids{ $_ } = 1 } @proposed_related;
-
- # None of these proposed related readings should have a neighbor that
- # is also in proposed_related.
- foreach my $pr ( keys %pr_ids ) {
- foreach my $neighbor( $self->sequence->neighbors( $pr ) ) {
- return 0 if exists $pr_ids{$neighbor};
- }
- }
- return 1;
}
}
-# Return a list of the witnesses in which the reading appears.
+sub add_relationship {
+ my $self = shift;
+ my( $source, $target, $opts ) = $self->_stringify_args( @_ );
+ my( @vectors ) = $self->relations->add_relationship( $source,
+ $self->reading( $source ), $target, $self->reading( $target ), $opts );
+ # Force a full rank recalculation every time. Yuck.
+ $self->calculate_ranks() if $self->end->has_rank;
+ return @vectors;
+}
+
+=head2 reading_witnesses( $reading )
+
+Return a list of sigils corresponding to the witnesses in which the reading appears.
+
+=cut
+
sub reading_witnesses {
my( $self, $reading ) = @_;
# We need only check either the incoming or the outgoing edges; I have
return keys %all_witnesses;
}
-sub related_readings {
- my( $self, $reading, $colocated ) = @_;
- my $return_object;
- if( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
- $reading = $reading->id;
- $return_object = 1;
-# print STDERR "Returning related objects\n";
-# } else {
-# print STDERR "Returning related object names\n";
- }
- my @related = $self->relations->all_reachable( $reading );
- if( $colocated ) {
- my @colo = grep { $self->relations->has_edge_attribute( $reading, $_, 'colocated' ) } @related;
- @related = @colo;
- }
- return $return_object ? map { $self->reading( $_ ) } @related : @related;
-}
+=head1 OUTPUT METHODS
-=head2 Output method(s)
-
-=over
-
-=item B<as_svg>
-
-print $graph->as_svg( $recalculate );
+=head2 as_svg( \%options )
Returns an SVG string that represents the graph, via as_dot and graphviz.
+See as_dot for a list of options.
=cut
sub as_svg {
- my( $self ) = @_;
+ my( $self, $opts ) = @_;
my @cmd = qw/dot -Tsvg/;
my( $svg, $err );
my $dotfile = File::Temp->new();
- ## TODO REMOVE
+ ## USE FOR DEBUGGING
# $dotfile->unlink_on_destroy(0);
binmode $dotfile, ':utf8';
- print $dotfile $self->as_dot();
+ print $dotfile $self->as_dot( $opts );
push( @cmd, $dotfile->filename );
run( \@cmd, ">", binary(), \$svg );
- $svg = decode_utf8( $svg );
- return $svg;
+ return decode_utf8( $svg );
}
-=item B<as_dot>
-print $graph->as_dot( $view, $recalculate );
+=head2 as_dot( \%options )
Returns a string that is the collation graph expressed in dot
-(i.e. GraphViz) format. The 'view' argument determines what kind of
-graph is produced.
- * 'path': a graph of witness paths through the collation (DEFAULT)
- * 'relationship': a graph of how collation readings relate to
- each other
+(i.e. GraphViz) format. Options include:
+
+=over 4
+
+=item * from
+
+=item * to
+
+=item * color_common
+
+=back
=cut
sub as_dot {
- my( $self, $view ) = @_;
- $view = 'sequence' unless $view;
+ my( $self, $opts ) = @_;
+ my $startrank = $opts->{'from'} if $opts;
+ my $endrank = $opts->{'to'} if $opts;
+ my $color_common = $opts->{'color_common'} if $opts;
+ my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank
+ && $self->end->rank > 100;
+
+ # Check the arguments
+ if( $startrank ) {
+ return if $endrank && $startrank > $endrank;
+ return if $startrank > $self->end->rank;
+ }
+ if( defined $endrank ) {
+ return if $endrank < 0;
+ $endrank = undef if $endrank == $self->end->rank;
+ }
+
# TODO consider making some of these things configurable
my $graph_name = $self->tradition->name;
$graph_name =~ s/[^\w\s]//g;
$graph_name = join( '_', split( /\s+/, $graph_name ) );
+
+ my %graph_attrs = (
+ 'rankdir' => 'LR',
+ 'bgcolor' => 'none',
+ );
+ my %node_attrs = (
+ 'fontsize' => 11,
+ 'fillcolor' => 'white',
+ 'style' => 'filled',
+ 'shape' => 'ellipse'
+ );
+ my %edge_attrs = (
+ 'arrowhead' => 'open',
+ 'color' => '#000000',
+ 'fontcolor' => '#000000',
+ );
+
my $dot = sprintf( "digraph %s {\n", $graph_name );
- $dot .= "\tedge [ arrowhead=open ];\n";
- $dot .= "\tgraph [ rankdir=LR ];\n";
- $dot .= sprintf( "\tnode [ fontsize=%d, fillcolor=%s, style=%s, shape=%s ];\n",
- 11, "white", "filled", "ellipse" );
+ $dot .= "\tgraph " . _dot_attr_string( \%graph_attrs ) . ";\n";
+ $dot .= "\tnode " . _dot_attr_string( \%node_attrs ) . ";\n";
+ # Output substitute start/end readings if necessary
+ if( $startrank ) {
+ $dot .= "\t\"#SUBSTART#\" [ label=\"...\" ];\n";
+ }
+ if( $endrank ) {
+ $dot .= "\t\"#SUBEND#\" [ label=\"...\" ];\n";
+ }
+ if( $STRAIGHTENHACK ) {
+ ## HACK part 1
+ $dot .= "\tsubgraph { rank=same \"#START#\" \"#SILENT#\" }\n";
+ $dot .= "\t\"#SILENT#\" [ shape=diamond,color=white,penwidth=0,label=\"\" ];"
+ }
+ my %used; # Keep track of the readings that actually appear in the graph
foreach my $reading ( $self->readings ) {
+ # Only output readings within our rank range.
+ next if $startrank && $reading->rank < $startrank;
+ next if $endrank && $reading->rank > $endrank;
+ $used{$reading->id} = 1;
# Need not output nodes without separate labels
next if $reading->id eq $reading->text;
+ my $rattrs;
my $label = $reading->text;
$label =~ s/\"/\\\"/g;
- $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $label );
+ $rattrs->{'label'} = $label;
+ $rattrs->{'fillcolor'} = '#b3f36d' if $reading->is_common && $color_common;
+ $dot .= sprintf( "\t\"%s\" %s;\n", $reading->id, _dot_attr_string( $rattrs ) );
}
- # TODO do something sensible for relationships
-
+ # Add the real edges
my @edges = $self->paths;
+ my( %substart, %subend );
foreach my $edge ( @edges ) {
- my %variables = ( 'color' => '#000000',
- 'fontcolor' => '#000000',
- 'label' => join( ', ', $self->path_display_label( $edge ) ),
- );
- my $varopts = join( ', ', map { $_.'="'.$variables{$_}.'"' } sort keys %variables );
- # Account for the rank gap if necessary
- my $rankgap = $self->reading( $edge->[1] )->rank
- - $self->reading( $edge->[0] )->rank;
- $varopts .= ", minlen=$rankgap" if $rankgap > 1;
- $dot .= sprintf( "\t\"%s\" -> \"%s\" [ %s ];\n",
- $edge->[0], $edge->[1], $varopts );
+ # Do we need to output this edge?
+ if( $used{$edge->[0]} && $used{$edge->[1]} ) {
+ my $label = $self->_path_display_label( $self->path_witnesses( $edge ) );
+ my $variables = { %edge_attrs, 'label' => $label };
+ # Account for the rank gap if necessary
+ if( $self->reading( $edge->[1] )->has_rank
+ && $self->reading( $edge->[0] )->has_rank
+ && $self->reading( $edge->[1] )->rank
+ - $self->reading( $edge->[0] )->rank > 1 ) {
+ $variables->{'minlen'} = $self->reading( $edge->[1] )->rank
+ - $self->reading( $edge->[0] )->rank;
+ }
+ # EXPERIMENTAL: make edge width reflect no. of witnesses
+ my $extrawidth = scalar( $self->path_witnesses( $edge ) ) * 0.2;
+ $variables->{'penwidth'} = $extrawidth + 0.8; # gives 1 for a single wit
+
+ my $varopts = _dot_attr_string( $variables );
+ $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
+ $edge->[0], $edge->[1], $varopts );
+ } elsif( $used{$edge->[0]} ) {
+ $subend{$edge->[0]} = 1;
+ } elsif( $used{$edge->[1]} ) {
+ $substart{$edge->[1]} = 1;
+ }
}
+ # Add substitute start and end edges if necessary
+ foreach my $node ( keys %substart ) {
+ my $witstr = $self->_path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
+ my $variables = { %edge_attrs, 'label' => $witstr };
+ my $varopts = _dot_attr_string( $variables );
+ $dot .= "\t\"#SUBSTART#\" -> \"$node\" $varopts;";
+ }
+ foreach my $node ( keys %subend ) {
+ my $witstr = $self->_path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
+ my $variables = { %edge_attrs, 'label' => $witstr };
+ my $varopts = _dot_attr_string( $variables );
+ $dot .= "\t\"$node\" -> \"#SUBEND#\" $varopts;";
+ }
+ # HACK part 2
+ if( $STRAIGHTENHACK ) {
+ $dot .= "\t\"#END#\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
+ }
+
$dot .= "}\n";
return $dot;
}
+sub _dot_attr_string {
+ my( $hash ) = @_;
+ my @attrs;
+ foreach my $k ( sort keys %$hash ) {
+ my $v = $hash->{$k};
+ push( @attrs, $k.'="'.$v.'"' );
+ }
+ return( '[ ' . join( ', ', @attrs ) . ' ]' );
+}
+
+=head2 path_witnesses( $edge )
+
+Returns the list of sigils whose witnesses are associated with the given edge.
+The edge can be passed as either an array or an arrayref of ( $source, $target ).
+
+=cut
+
sub path_witnesses {
my( $self, @edge ) = @_;
# If edge is an arrayref, cope.
@edge = @$e;
}
my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
- return sort @wits;
+ return @wits;
}
-sub path_display_label {
- my( $self, $edge ) = @_;
- my @wits = $self->path_witnesses( $edge );
+sub _path_display_label {
+ my $self = shift;
+ my @wits = sort @_;
my $maj = scalar( $self->tradition->witnesses ) * 0.6;
if( scalar @wits > $maj ) {
+ # TODO break out a.c. wits
return 'majority';
} else {
return join( ', ', @wits );
}
-=item B<as_graphml>
+=head2 as_graphml
+
+Returns a GraphML representation of the collation. The GraphML will contain
+two graphs. The first expresses the attributes of the readings and the witness
+paths that link them; the second expresses the relationships that link the
+readings. This is the native transfer format for a tradition.
+
+=begin testing
+
+use Text::Tradition;
+
+my $READINGS = 311;
+my $PATHS = 361;
-print $graph->as_graphml( $recalculate )
+my $datafile = 't/data/florilegium_tei_ps.xml';
+my $tradition = Text::Tradition->new( 'input' => 'TEI',
+ 'name' => 'test0',
+ 'file' => $datafile,
+ 'linear' => 1 );
-Returns a GraphML representation of the collation graph, with
-transposition information and position information. Unless
-$recalculate is passed (and is a true value), the method will return a
-cached copy of the SVG after the first call to the method.
+ok( $tradition, "Got a tradition object" );
+is( scalar $tradition->witnesses, 13, "Found all witnesses" );
+ok( $tradition->collation, "Tradition has a collation" );
+
+my $c = $tradition->collation;
+is( scalar $c->readings, $READINGS, "Collation has all readings" );
+is( scalar $c->paths, $PATHS, "Collation has all paths" );
+is( scalar $c->relationships, 0, "Collation has all relationships" );
+
+# Add a few relationships
+$c->add_relationship( 'w123', 'w125', { 'type' => 'collated' } );
+$c->add_relationship( 'w193', 'w196', { 'type' => 'collated' } );
+$c->add_relationship( 'w257', 'w262', { 'type' => 'transposition' } );
+
+# Now write it to GraphML and parse it again.
+
+my $graphml = $c->as_graphml;
+my $st = Text::Tradition->new( 'input' => 'Self', 'string' => $graphml );
+is( scalar $st->collation->readings, $READINGS, "Reparsed collation has all readings" );
+is( scalar $st->collation->paths, $PATHS, "Reparsed collation has all paths" );
+is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
+
+=end testing
=cut
my $edi = 0;
my %edge_data_keys;
my %edge_data = (
+ class => 'string', # Class, deprecated soon
witness => 'string', # ID/label for a path
relationship => 'string', # ID/label for a relationship
extra => 'boolean', # Path key
- colocated => 'boolean', # Relationship key
+ scope => 'string', # Relationship key
non_correctable => 'boolean', # Relationship key
non_independent => 'boolean', # Relationship key
);
$key->setAttribute( 'id', $edge_data_keys{$datum} );
}
- # Add the collation graphs themselves
+ # Add the collation graph itself
my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
$sgraph->setAttribute( 'edgedefault', 'directed' );
$sgraph->setAttribute( 'id', $self->tradition->name );
$sgraph->setAttribute( 'parse.nodeids', 'canonical' );
$sgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
$sgraph->setAttribute( 'parse.order', 'nodesfirst' );
-
- my $rgraph = $root->addNewChild( $graphml_ns, 'graph' );
- $rgraph->setAttribute( 'edgedefault', 'undirected' );
- $rgraph->setAttribute( 'id', 'relationships' );
- $rgraph->setAttribute( 'parse.edgeids', 'canonical' );
- $rgraph->setAttribute( 'parse.edges', scalar($self->relationships) );
- $rgraph->setAttribute( 'parse.nodeids', 'canonical' );
- $rgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
- $rgraph->setAttribute( 'parse.order', 'nodesfirst' );
-
+
# Collation attribute data
foreach my $datum ( @graph_attributes ) {
my $value = $datum eq 'version' ? '3.0' : $self->$datum;
my $node_ctr = 0;
my %node_hash;
- # Add our readings to the graphs
+ # Add our readings to the graph
foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
# Add to the main graph
my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
_add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
if defined $nval;
}
- # Add to the relationships graph
- my $rnode_el = $rgraph->addNewChild( $graphml_ns, 'node' );
- $rnode_el->setAttribute( 'id', $node_xmlid );
}
# Add the path edges to the sequence graph
my $edge_ctr = 0;
foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->sequence->edges() ) {
# We add an edge in the graphml for every witness in $e.
- foreach my $wit ( $self->path_witnesses( $e ) ) {
+ foreach my $wit ( sort $self->path_witnesses( $e ) ) {
my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
$node_hash{ $e->[0] },
$node_hash{ $e->[1] } );
_add_graphml_data( $edge_el, $edge_data_keys{'extra'}, $aclabel );
}
_add_graphml_data( $edge_el, $edge_data_keys{'witness'}, $base );
+ _add_graphml_data( $edge_el, $edge_data_keys{'class'}, 'path' );
}
}
- # Add the relationship edges to the relationships graph
- foreach my $e ( sort { $a->[0] cmp $b->[0] } $self->relationships ) {
- my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
- $node_hash{ $e->[0] },
- $node_hash{ $e->[1] } );
- my $edge_el = $rgraph->addNewChild( $graphml_ns, 'edge' );
- $edge_el->setAttribute( 'source', $from );
- $edge_el->setAttribute( 'target', $to );
- $edge_el->setAttribute( 'id', $id );
-
- my $data = $self->relations->get_edge_attributes( @$e );
- # It's a relationship, so save the relationship data
- _add_graphml_data( $edge_el, $edge_data_keys{'relationship'}, $data->{type} );
- _add_graphml_data( $edge_el, $edge_data_keys{'colocated'}, $data->{colocated} );
- if( exists $data->{non_correctable} ) {
- _add_graphml_data( $edge_el, $edge_data_keys{'non_correctable'},
- $data->{non_correctable} );
- }
- if( exists $data->{non_independent} ) {
- _add_graphml_data( $edge_el, $edge_data_keys{'non_independent'},
- $data->{non_independent} );
- }
- }
+ # Add the relationship graph to the XML
+ $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
+ $node_data_keys{'id'}, \%edge_data_keys );
# Save and return the thing
my $result = decode_utf8( $graphml->toString(1) );
$data_el->appendText( $value );
}
-=item B<as_csv>
-
-print $graph->as_csv( $recalculate )
+=head2 as_csv
Returns a CSV alignment table representation of the collation graph, one
row per witness (or witness uncorrected.)
return join( "\n", @result );
}
-=item B<make_alignment_table>
-
-my $table = $graph->make_alignment_table( $use_refs, \@wits_to_include )
+=head2 make_alignment_table( $use_refs, $include_witnesses )
Return a reference to an alignment table, in a slightly enhanced CollateX
format which looks like this:
$table = { alignment => [ { witness => "SIGIL",
- tokens => [ { t => "READINGTEXT" }, ... ] },
+ tokens => [ { t => "TEXT" }, ... ] },
{ witness => "SIG2",
- tokens => [ { t => "READINGTEXT" }, ... ] },
+ tokens => [ { t => "TEXT" }, ... ] },
... ],
length => TEXTLEN };
If $use_refs is set to 1, the reading object is returned in the table
instead of READINGTEXT; if not, the text of the reading is returned.
-If $wits_to_include is set to a hashref, only the witnesses whose sigil
+
+If $include_witnesses is set to a hashref, only the witnesses whose sigil
keys have a true hash value will be included.
=cut
sub make_alignment_table {
my( $self, $noderefs, $include ) = @_;
- unless( $self->linear ) {
- warn "Need a linear graph in order to make an alignment table";
- return;
- }
+ # Make sure we can do this
+ throw( "Need a linear graph in order to make an alignment table" )
+ unless $self->linear;
+ $self->calculate_ranks unless $self->end->has_rank;
+
my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
my @all_pos = ( 1 .. $self->end->rank - 1 );
foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
{ 'witness' => $wit->sigil, 'tokens' => \@row } );
if( $wit->is_layered ) {
my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
- $wit->sigil.$self->ac_label, $wit->sigil );
+ $wit->sigil.$self->ac_label );
my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos, $noderefs );
push( @{$table->{'alignment'}},
{ 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
return $result;
}
-=back
-
-=head2 Navigation methods
-
-=over
-
-=item B<start>
-
-my $beginning = $collation->start();
-
-Returns the beginning of the collation, a meta-reading with label '#START#'.
-
-=item B<end>
-
-my $end = $collation->end();
+=head1 NAVIGATION METHODS
-Returns the end of the collation, a meta-reading with label '#END#'.
-
-
-=item B<reading_sequence>
-
-my @readings = $graph->reading_sequence( $first, $last, $path[, $alt_path] );
+=head2 reading_sequence( $first, $last, $sigil, $backup )
Returns the ordered list of readings, starting with $first and ending
-with $last, along the given witness path. If no path is specified,
-assume that the path is that of the base text (if any.)
+with $last, for the witness given in $sigil. If a $backup sigil is
+specified (e.g. when walking a layered witness), it will be used wherever
+no $sigil path exists. If there is a base text reading, that will be
+used wherever no path exists for $sigil or $backup.
=cut
# TODO Think about returning some lazy-eval iterator.
+# TODO Get rid of backup; we should know from what witness is whether we need it.
sub reading_sequence {
- my( $self, $start, $end, $witness, $backup ) = @_;
+ my( $self, $start, $end, $witness ) = @_;
$witness = $self->baselabel unless $witness;
my @readings = ( $start );
my $n = $start;
while( $n && $n->id ne $end->id ) {
if( exists( $seen{$n->id} ) ) {
- warn "Detected loop at " . $n->id;
- last;
+ throw( "Detected loop for $witness at " . $n->id );
}
$seen{$n->id} = 1;
- my $next = $self->next_reading( $n, $witness, $backup );
+ my $next = $self->next_reading( $n, $witness );
unless( $next ) {
- warn "Did not find any path for $witness from reading " . $n->id;
- last;
+ throw( "Did not find any path for $witness from reading " . $n->id );
}
push( @readings, $next );
$n = $next;
}
# Check that the last reading is our end reading.
my $last = $readings[$#readings];
- warn "Last reading found from " . $start->text .
- " for witness $witness is not the end!"
+ throw( "Last reading found from " . $start->text .
+ " for witness $witness is not the end!" ) # TODO do we get this far?
unless $last->id eq $end->id;
return @readings;
}
-=item B<next_reading>
-
-my $next_reading = $graph->next_reading( $reading, $witpath );
+=head2 next_reading( $reading, $sigil );
Returns the reading that follows the given reading along the given witness
path.
return $self->reading( $answer );
}
-=item B<prior_reading>
-
-my $prior_reading = $graph->prior_reading( $reading, $witpath );
+=head2 prior_reading( $reading, $sigil )
Returns the reading that precedes the given reading along the given witness
path.
}
sub _find_linked_reading {
- my( $self, $direction, $node, $path, $alt_path ) = @_;
+ my( $self, $direction, $node, $path ) = @_;
+
+ # Get a backup if we are dealing with a layered witness
+ my $alt_path;
+ my $aclabel = $self->ac_label;
+ if( $path && $path =~ /^(.*)\Q$aclabel\E$/ ) {
+ $alt_path = $1;
+ }
+
my @linked_paths = $direction eq 'next'
? $self->sequence->edges_from( $node )
: $self->sequence->edges_to( $node );
# We have to find the linked path that contains all of the
# witnesses supplied in $path.
my( @path_wits, @alt_path_wits );
- @path_wits = sort( $self->witnesses_of_label( $path ) ) if $path;
- @alt_path_wits = sort( $self->witnesses_of_label( $alt_path ) ) if $alt_path;
+ @path_wits = sort( $self->_witnesses_of_label( $path ) ) if $path;
+ @alt_path_wits = sort( $self->_witnesses_of_label( $alt_path ) ) if $alt_path;
my $base_le;
my $alt_le;
foreach my $le ( @linked_paths ) {
if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
$base_le = $le;
}
- my @le_wits = $self->path_witnesses( $le );
+ my @le_wits = sort $self->path_witnesses( $le );
if( _is_within( \@path_wits, \@le_wits ) ) {
# This is the right path.
return $direction eq 'next' ? $le->[1] : $le->[0];
return $ret;
}
+# Return the string that joins together a list of witnesses for
+# display on a single path.
+sub _witnesses_of_label {
+ my( $self, $label ) = @_;
+ my $regex = $self->wit_list_separator;
+ my @answer = split( /\Q$regex\E/, $label );
+ return @answer;
+}
+
+=head2 common_readings
+
+Returns the list of common readings in the graph (i.e. those readings that are
+shared by all non-lacunose witnesses.)
+
+=cut
+
+sub common_readings {
+ my $self = shift;
+ my @common = grep { $_->is_common } $self->readings;
+ return @common;
+}
+
+=head2 path_text( $sigil, $mainsigil [, $start, $end ] )
+
+Returns the text of a witness (plus its backup, if we are using a layer)
+as stored in the collation. The text is returned as a string, where the
+individual readings are joined with spaces and the meta-readings (e.g.
+lacunae) are omitted. Optional specification of $start and $end allows
+the generation of a subset of the witness text.
-## INITIALIZATION METHODS - for use by parsers
+=cut
+
+sub path_text {
+ my( $self, $wit, $start, $end ) = @_;
+ $start = $self->start unless $start;
+ $end = $self->end unless $end;
+ my @path = grep { !$_->is_meta } $self->reading_sequence( $start, $end, $wit );
+ return join( ' ', map { $_->text } @path );
+}
+
+=head1 INITIALIZATION METHODS
+
+These are mostly for use by parsers.
+
+=head2 make_witness_path( $witness )
+
+Link the array of readings contained in $witness->path (and in
+$witness->uncorrected_path if it exists) into collation paths.
+Clear out the arrays when finished.
+
+=head2 make_witness_paths
+
+Call make_witness_path for all witnesses in the tradition.
+
+=cut
# For use when a collation is constructed from a base text and an apparatus.
# We have the sequences of readings and just need to add path edges.
$wit->clear_uncorrected_path;
}
+=head2 calculate_ranks
+
+Calculate the reading ranks (that is, their aligned positions relative
+to each other) for the graph. This can only be called on linear collations.
+
+=cut
+
sub calculate_ranks {
my $self = shift;
# Walk a version of the graph where every node linked by a relationship
foreach my $n ( $self->sequence->successors( $r->id ) ) {
my( $tfrom, $tto ) = ( $rel_containers{$r->id},
$rel_containers{$n} );
- $DB::single = 1 unless $tfrom && $tto;
+ # $DB::single = 1 unless $tfrom && $tto;
$topo_graph->add_edge( $tfrom, $tto );
}
}
if( defined $node_ranks->{$rel_containers{$r->id}} ) {
$r->rank( $node_ranks->{$rel_containers{$r->id}} );
} else {
- $DB::single = 1;
- die "No rank calculated for node " . $r->id
- . " - do you have a cycle in the graph?";
+ # Die. Find the last rank we calculated.
+ my @all_defined = sort { $node_ranks->{$rel_containers{$a->id}}
+ <=> $node_ranks->{$rel_containers{$b->id}} }
+ $self->readings;
+ my $last = pop @all_defined;
+ throw( "Ranks not calculated after $last - do you have a cycle in the graph?" );
}
}
}
return @next_nodes;
}
-# Another method to make up for rough collation methods. If the same reading
-# appears multiple times at the same rank, collapse the nodes.
+=head2 flatten_ranks
+
+A convenience method for parsing collation data. Searches the graph for readings
+with the same text at the same rank, and merges any that are found.
+
+=cut
+
sub flatten_ranks {
my $self = shift;
my %unique_rank_rdg;
my $key = $rdg->rank . "||" . $rdg->text;
if( exists $unique_rank_rdg{$key} ) {
# Combine!
- # print STDERR "Combining readings at same rank: $key\n";
+ # print STDERR "Combining readings at same rank: $key\n";
$self->merge_readings( $unique_rank_rdg{$key}, $rdg );
+ # TODO see if this now makes a common point.
} else {
$unique_rank_rdg{$key} = $rdg;
}
}
}
+=head2 calculate_common_readings
+
+Goes through the graph identifying the readings that appear in every witness
+(apart from those with lacunae at that spot.) Marks them as common and returns
+the list.
+
+=begin testing
+
+use Text::Tradition;
+
+my $cxfile = 't/data/Collatex-16.xml';
+my $t = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'CollateX',
+ 'file' => $cxfile,
+ );
+my $c = $t->collation;
+
+my @common = $c->calculate_common_readings();
+is( scalar @common, 8, "Found correct number of common readings" );
+my @marked = sort $c->common_readings();
+is( scalar @common, 8, "All common readings got marked as such" );
+my @expected = qw/ n1 n12 n16 n19 n20 n5 n6 n7 /;
+is_deeply( \@marked, \@expected, "Found correct list of common readings" );
+
+=end testing
+
+=cut
+
+sub calculate_common_readings {
+ my $self = shift;
+ my @common;
+ my $table = $self->make_alignment_table( 1 );
+ foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
+ my @row = map { $_->{'tokens'}->[$idx]->{'t'} } @{$table->{'alignment'}};
+ my %hash;
+ foreach my $r ( @row ) {
+ if( $r ) {
+ $hash{$r->id} = $r unless $r->is_meta;
+ } else {
+ $hash{'UNDEF'} = $r;
+ }
+ }
+ if( keys %hash == 1 && !exists $hash{'UNDEF'} ) {
+ my( $r ) = values %hash;
+ $r->is_common( 1 );
+ push( @common, $r );
+ }
+ }
+ return @common;
+}
+
+=head2 text_from_paths
+
+Calculate the text array for all witnesses from the path, for later consistency
+checking. Only to be used if there is no non-graph-based way to know the
+original texts.
+
+=cut
+
+sub text_from_paths {
+ my $self = shift;
+ foreach my $wit ( $self->tradition->witnesses ) {
+ my @text = split( /\s+/,
+ $self->reading_sequence( $self->start, $self->end, $wit->sigil ) );
+ $wit->text( \@text );
+ if( $wit->is_layered ) {
+ my @uctext = split( /\s+/,
+ $self->reading_sequence( $self->start, $self->end,
+ $wit->sigil.$self->ac_label ) );
+ $wit->text( \@uctext );
+ }
+ }
+}
-## Utility functions
+=head1 UTILITY FUNCTIONS
+
+=head2 common_predecessor( $reading_a, $reading_b )
+
+Find the last reading that occurs in sequence before both the given readings.
+
+=head2 common_successor( $reading_a, $reading_b )
+
+Find the first reading that occurs in sequence after both the given readings.
-# Return the string that joins together a list of witnesses for
-# display on a single path.
-sub witnesses_of_label {
- my( $self, $label ) = @_;
- my $regex = $self->wit_list_separator;
- my @answer = split( /\Q$regex\E/, $label );
- return @answer;
-}
+=begin testing
+
+use Text::Tradition;
+
+my $cxfile = 't/data/Collatex-16.xml';
+my $t = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'CollateX',
+ 'file' => $cxfile,
+ );
+my $c = $t->collation;
+
+is( $c->common_predecessor( 'n9', 'n23' )->id,
+ 'n20', "Found correct common predecessor" );
+is( $c->common_successor( 'n9', 'n23' )->id,
+ '#END#', "Found correct common successor" );
+
+is( $c->common_predecessor( 'n19', 'n17' )->id,
+ 'n16', "Found correct common predecessor for readings on same path" );
+is( $c->common_successor( 'n21', 'n26' )->id,
+ '#END#', "Found correct common successor for readings on same path" );
+
+=end testing
+
+=cut
+
+## Return the closest reading that is a predecessor of both the given readings.
+sub common_predecessor {
+ my $self = shift;
+ my( $r1, $r2 ) = $self->_objectify_args( @_ );
+ return $self->_common_in_path( $r1, $r2, 'predecessors' );
+}
+
+sub common_successor {
+ my $self = shift;
+ my( $r1, $r2 ) = $self->_objectify_args( @_ );
+ return $self->_common_in_path( $r1, $r2, 'successors' );
+}
+
+sub _common_in_path {
+ my( $self, $r1, $r2, $dir ) = @_;
+ my $iter = $r1->rank > $r2->rank ? $r1->rank : $r2->rank;
+ $iter = $self->end->rank - $iter if $dir eq 'successors';
+ my @candidates;
+ my @last_checked = ( $r1, $r2 );
+ my %all_seen;
+ while( !@candidates ) {
+ my @new_lc;
+ foreach my $lc ( @last_checked ) {
+ foreach my $p ( $lc->$dir ) {
+ if( $all_seen{$p->id} ) {
+ push( @candidates, $p );
+ } else {
+ $all_seen{$p->id} = 1;
+ push( @new_lc, $p );
+ }
+ }
+ }
+ @last_checked = @new_lc;
+ }
+ my @answer = sort { $a->rank <=> $b->rank } @candidates;
+ return $dir eq 'predecessors' ? pop( @answer ) : shift ( @answer );
+}
+
+sub throw {
+ Text::Tradition::Error->throw(
+ 'ident' => 'Collation error',
+ 'message' => $_[0],
+ );
+}
no Moose;
__PACKAGE__->meta->make_immutable;
-=head1 BUGS / TODO
+=head1 LICENSE
-=over
+This package is free software and is provided "as is" without express
+or implied warranty. You can redistribute it and/or modify it under
+the same terms as Perl itself.
-=item * Think about making Relationship objects again
+=head1 AUTHOR
-=back
+Tara L Andrews E<lt>aurum@cpan.orgE<gt>
projects / scpubgit/stemmatology.git / blobdiff