package Text::Tradition::Collation;
-use Graph::Easy;
+use Encode qw( decode_utf8 );
+use File::Temp;
+use Graph;
use IPC::Run qw( run binary );
+use Text::CSV_XS;
use Text::Tradition::Collation::Reading;
+use XML::LibXML;
use Moose;
-has 'graph' => (
+has 'sequence' => (
is => 'ro',
- isa => 'Graph::Easy',
+ isa => 'Graph',
+ default => sub { Graph->new() },
handles => {
- add_reading => 'add_node',
- del_reading => 'del_node',
- add_path => 'add_edge',
- del_path => 'del_edge',
- reading => 'node',
- path => 'edge',
- readings => 'nodes',
- paths => 'edges',
+ paths => 'edges',
},
- default => sub { Graph::Easy->new( undirected => 0 ) },
);
-
+
+has 'relations' => (
+ is => 'ro',
+ isa => 'Graph',
+ default => sub { Graph->new( undirected => 1 ) },
+ handles => {
+ relationships => 'edges',
+ },
+ );
has 'tradition' => (
- is => 'rw',
+ is => 'ro',
isa => 'Text::Tradition',
+ weak_ref => 1,
);
-has 'svg' => (
- is => 'ro',
+has 'readings' => (
+ isa => 'HashRef[Text::Tradition::Collation::Reading]',
+ traits => ['Hash'],
+ handles => {
+ reading => 'get',
+ _add_reading => 'set',
+ del_reading => 'delete',
+ has_reading => 'exists',
+ readings => 'values',
+ },
+ default => sub { {} },
+ );
+
+has 'wit_list_separator' => (
+ is => 'rw',
isa => 'Str',
- writer => '_save_svg',
- predicate => 'has_svg',
+ default => ', ',
);
-has 'graphviz' => (
- is => 'ro',
+has 'baselabel' => (
+ is => 'rw',
isa => 'Str',
- writer => '_save_graphviz',
- predicate => 'has_graphviz',
+ default => 'base text',
);
-has 'graphml' => (
- is => 'ro',
- isa => 'XML::LibXML::Document',
- writer => '_save_graphml',
- predicate => 'has_graphml',
+has 'linear' => (
+ is => 'rw',
+ isa => 'Bool',
+ default => 1,
);
-# Keeps track of the lemmas within the collation. At most one lemma
-# per position in the graph.
-has 'lemmata' => (
- is => 'ro',
- isa => 'HashRef[Maybe[Str]]',
- default => sub { {} },
+has 'ac_label' => (
+ is => 'rw',
+ isa => 'Str',
+ default => ' (a.c.)',
);
-
-has 'wit_list_separator' => (
- is => 'rw',
- isa => 'Str',
- default => ', ',
- );
+
+has 'start' => (
+ is => 'ro',
+ isa => 'Text::Tradition::Collation::Reading',
+ writer => '_set_start',
+ weak_ref => 1,
+ );
+
+has 'end' => (
+ is => 'ro',
+ isa => 'Text::Tradition::Collation::Reading',
+ writer => '_set_end',
+ weak_ref => 1,
+ );
# The collation can be created two ways:
# 1. Collate a set of witnesses (with CollateX I guess) and process
# come through option 1.
sub BUILD {
- my( $self, $args ) = @_;
- $self->graph->use_class('node', 'Text::Tradition::Collation::Reading');
-
- # Pass through any graph-specific options.
- my $shape = exists( $args->{'shape'} ) ? $args->{'shape'} : 'ellipse';
- $self->graph->set_attribute( 'node', 'shape', $shape );
+ my $self = shift;
+ $self->_set_start( $self->add_reading( { 'collation' => $self, 'is_start' => 1 } ) );
+ $self->_set_end( $self->add_reading( { 'collation' => $self, 'is_end' => 1 } ) );
}
-# Wrappes around merge_nodes
+### Reading construct/destruct functions
+
+sub add_reading {
+ my( $self, $reading ) = @_;
+ unless( ref( $reading ) eq 'Text::Tradition::Collation::Reading' ) {
+ my %args = %$reading;
+ $reading = Text::Tradition::Collation::Reading->new(
+ 'collation' => $self,
+ %args );
+ }
+ # 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;
+ }
+ $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 );
+ return $reading;
+};
+
+around del_reading => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $arg = shift;
+
+ if( ref( $arg ) eq 'Text::Tradition::Collation::Reading' ) {
+ $arg = $arg->id;
+ }
+ # Remove the reading from the graphs.
+ $self->sequence->delete_vertex( $arg );
+ $self->relations->delete_vertex( $arg );
+
+ # Carry on.
+ $self->$orig( $arg );
+};
+
+# merge_readings( $main, $to_be_deleted );
sub merge_readings {
- my $self = shift;
- my $first_node = shift;
- my $second_node = shift;
- $first_node->merge_from( $second_node );
- unshift( @_, $first_node, $second_node );
- return $self->graph->merge_nodes( @_ );
+ my $self = shift;
+
+ # We only need the IDs for adding paths to the graph, not the reading
+ # objects themselves.
+ my( $kept, $deleted, $combine_char ) = $self->_stringify_args( @_ );
+
+ # The kept reading should inherit the paths and the relationships
+ # of the deleted reading.
+ foreach my $path ( $self->sequence->edges_at( $deleted ) ) {
+ my @vector = ( $kept );
+ push( @vector, $path->[1] ) if $path->[0] eq $deleted;
+ unshift( @vector, $path->[0] ) if $path->[1] eq $deleted;
+ next if $vector[0] eq $vector[1]; # Don't add a self loop
+ my %wits = %{$self->sequence->get_edge_attributes( @$path )};
+ $self->sequence->add_edge( @vector );
+ my $fwits = $self->sequence->get_edge_attributes( @vector );
+ @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 );
+ }
+
+ # Do the deletion deed.
+ if( $combine_char ) {
+ my $kept_obj = $self->reading( $kept );
+ my $new_text = join( $combine_char, $kept_obj->text,
+ $self->reading( $deleted )->text );
+ $kept_obj->alter_text( $new_text );
+ }
+ $self->del_reading( $deleted );
+}
+
+
+# Helper function for manipulating the graph.
+sub _stringify_args {
+ my( $self, $first, $second, $arg ) = @_;
+ $first = $first->id
+ if ref( $first ) eq 'Text::Tradition::Collation::Reading';
+ $second = $second->id
+ if ref( $second ) eq 'Text::Tradition::Collation::Reading';
+ return( $first, $second, $arg );
+}
+
+### Path logic
+
+sub add_path {
+ my $self = shift;
+
+ # We only need the IDs for adding paths to the graph, not the reading
+ # objects themselves.
+ my( $source, $target, $wit ) = $self->_stringify_args( @_ );
+
+ # Connect the readings
+ $self->sequence->add_edge( $source, $target );
+ # Note the witness in question
+ $self->sequence->set_edge_attribute( $source, $target, $wit, 1 );
+};
+
+sub del_path {
+ my $self = shift;
+ my @args;
+ if( ref( $_[0] ) eq 'ARRAY' ) {
+ my $e = shift @_;
+ @args = ( @$e, @_ );
+ } else {
+ @args = @_;
+ }
+
+ # We only need the IDs for adding paths to the graph, not the reading
+ # objects themselves.
+ my( $source, $target, $wit ) = $self->_stringify_args( @args );
+
+ if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
+ $self->sequence->delete_edge_attribute( $source, $target, $wit );
+ }
+ unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
+ $self->sequence->delete_edge( $source, $target );
+ }
+}
+
+
+# Extra graph-alike utility
+sub has_path {
+ my $self = shift;
+ my( $source, $target, $wit ) = $self->_stringify_args( @_ );
+ return undef unless $self->sequence->has_edge( $source, $target );
+ return $self->sequence->has_edge_attribute( $source, $target, $wit );
+}
+
+### Relationship logic
+
+=head2 add_relationship( $reading1, $reading2, $definition )
+
+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
+
+=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 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;
+ }
+
+ # 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};
+ }
+ 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 reading_witnesses {
+ my( $self, $reading ) = @_;
+ # We need only check either the incoming or the outgoing edges; I have
+ # arbitrarily chosen "incoming". Thus, special-case the start node.
+ if( $reading eq $self->start ) {
+ return map { $_->sigil } $self->tradition->witnesses;
+ }
+ my %all_witnesses;
+ foreach my $e ( $self->sequence->edges_to( $reading ) ) {
+ my $wits = $self->sequence->get_edge_attributes( @$e );
+ @all_witnesses{ keys %$wits } = 1;
+ }
+ 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;
}
=head2 Output method(s)
print $graph->as_svg( $recalculate );
-Returns an SVG string that represents the graph. Uses GraphViz to do
-this, because Graph::Easy doesn\'t cope well with long graphs. 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.
+Returns an SVG string that represents the graph, via as_dot and graphviz.
=cut
sub as_svg {
- my( $self, $recalc ) = @_;
- return $self->svg if $self->has_svg;
-
- $self->_save_graphviz( $self->graph->as_graphviz() )
- unless( $self->has_graphviz && !$recalc );
-
+ my( $self ) = @_;
+
my @cmd = qw/dot -Tsvg/;
my( $svg, $err );
- my $in = $self->graphviz;
- run( \@cmd, \$in, ">", binary(), \$svg );
- $self->{'svg'} = $svg;
+ my $dotfile = File::Temp->new();
+ ## TODO REMOVE
+ # $dotfile->unlink_on_destroy(0);
+ binmode $dotfile, ':utf8';
+ print $dotfile $self->as_dot();
+ push( @cmd, $dotfile->filename );
+ run( \@cmd, ">", binary(), \$svg );
+ $svg = decode_utf8( $svg );
return $svg;
}
+=item B<as_dot>
+
+print $graph->as_dot( $view, $recalculate );
+
+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
+
+=cut
+
+sub as_dot {
+ my( $self, $view ) = @_;
+ $view = 'sequence' unless $view;
+ # 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 $dot = sprintf( "digraph %s {\n", $graph_name );
+ $dot .= "\tedge [ arrowhead=open ];\n";
+ $dot .= "\tgraph [ rankdir=LR,bgcolor=none ];\n";
+ $dot .= sprintf( "\tnode [ fontsize=%d, fillcolor=%s, style=%s, shape=%s ];\n",
+ 11, "white", "filled", "ellipse" );
+
+ foreach my $reading ( $self->readings ) {
+ # Need not output nodes without separate labels
+ next if $reading->id eq $reading->text;
+ my $label = $reading->text;
+ $label =~ s/\"/\\\"/g;
+ $dot .= sprintf( "\t\"%s\" [ label=\"%s\" ];\n", $reading->id, $label );
+ }
+
+ # TODO do something sensible for relationships
+
+ my @edges = $self->paths;
+ 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 );
+ }
+ $dot .= "}\n";
+ return $dot;
+}
+
+sub path_witnesses {
+ my( $self, @edge ) = @_;
+ # If edge is an arrayref, cope.
+ if( @edge == 1 && ref( $edge[0] ) eq 'ARRAY' ) {
+ my $e = shift @edge;
+ @edge = @$e;
+ }
+ my @wits = keys %{$self->sequence->get_edge_attributes( @edge )};
+ return sort @wits;
+}
+
+sub path_display_label {
+ my( $self, $edge ) = @_;
+ my @wits = $self->path_witnesses( $edge );
+ my $maj = scalar( $self->tradition->witnesses ) * 0.6;
+ if( scalar @wits > $maj ) {
+ return 'majority';
+ } else {
+ return join( ', ', @wits );
+ }
+}
+
+
=item B<as_graphml>
print $graph->as_graphml( $recalculate )
=cut
sub as_graphml {
- my( $self, $recalc ) = @_;
- return $self->graphml if $self->has_graphml;
+ my( $self ) = @_;
# Some namespaces
my $graphml_ns = 'http://graphml.graphdrawing.org/xmlns';
my $xsi_ns = 'http://www.w3.org/2001/XMLSchema-instance';
my $graphml_schema = 'http://graphml.graphdrawing.org/xmlns ' .
- 'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
+ 'http://graphml.graphdrawing.org/xmlns/1.0/graphml.xsd';
# Create the document and root node
my $graphml = XML::LibXML->createDocument( "1.0", "UTF-8" );
$root->setNamespace( $xsi_ns, 'xsi', 0 );
$root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
+ # Add the data keys for the graph
+ my %graph_data_keys;
+ my $gdi = 0;
+ my @graph_attributes = qw/ version wit_list_separator baselabel linear ac_label /;
+ foreach my $datum ( @graph_attributes ) {
+ $graph_data_keys{$datum} = 'dg'.$gdi++;
+ my $key = $root->addNewChild( $graphml_ns, 'key' );
+ $key->setAttribute( 'attr.name', $datum );
+ $key->setAttribute( 'attr.type', $key eq 'linear' ? 'boolean' : 'string' );
+ $key->setAttribute( 'for', 'graph' );
+ $key->setAttribute( 'id', $graph_data_keys{$datum} );
+ }
+
# Add the data keys for nodes
- my @node_data = ( 'name', 'token', 'identical', 'position' );
- foreach my $ndi ( 0 .. $#node_data ) {
- my $key = $root->addNewChild( $graphml_ns, 'key' );
- $key->setAttribute( 'attr.name', $node_data[$ndi] );
- $key->setAttribute( 'attr.type', 'string' );
- $key->setAttribute( 'for', 'node' );
- $key->setAttribute( 'id', 'd'.$ndi );
+ my %node_data_keys;
+ my $ndi = 0;
+ my %node_data = (
+ id => 'string',
+ text => 'string',
+ rank => 'string',
+ is_start => 'boolean',
+ is_end => 'boolean',
+ is_lacuna => 'boolean',
+ );
+ foreach my $datum ( keys %node_data ) {
+ $node_data_keys{$datum} = 'dn'.$ndi++;
+ my $key = $root->addNewChild( $graphml_ns, 'key' );
+ $key->setAttribute( 'attr.name', $datum );
+ $key->setAttribute( 'attr.type', $node_data{$datum} );
+ $key->setAttribute( 'for', 'node' );
+ $key->setAttribute( 'id', $node_data_keys{$datum} );
}
- # Add the data keys for edges
- my %wit_hash;
- my $wit_ctr = 0;
- foreach my $wit ( $self->getWitnessList ) {
- my $wit_key = 'w' . $wit_ctr++;
- $wit_hash{$wit} = $wit_key;
- my $key = $root->addNewChild( $graphml_ns, 'key' );
- $key->setAttribute( 'attr.name', $wit );
- $key->setAttribute( 'attr.type', 'string' );
- $key->setAttribute( 'for', 'edge' );
- $key->setAttribute( 'id', $wit_key );
+ # Add the data keys for edges, i.e. witnesses
+ 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
+ non_correctable => 'boolean', # Relationship key
+ non_independent => 'boolean', # Relationship key
+ );
+ foreach my $datum ( keys %edge_data ) {
+ $edge_data_keys{$datum} = 'de'.$edi++;
+ my $key = $root->addNewChild( $graphml_ns, 'key' );
+ $key->setAttribute( 'attr.name', $datum );
+ $key->setAttribute( 'attr.type', $edge_data{$datum} );
+ $key->setAttribute( 'for', 'edge' );
+ $key->setAttribute( 'id', $edge_data_keys{$datum} );
}
- # Add the graph, its nodes, and its edges
- my $graph = $root->addNewChild( $graphml_ns, 'graph' );
- $graph->setAttribute( 'edgedefault', 'directed' );
- $graph->setAttribute( 'id', 'g0' ); # TODO make this meaningful
- $graph->setAttribute( 'parse.edgeids', 'canonical' );
- $graph->setAttribute( 'parse.edges', $self->edges() );
- $graph->setAttribute( 'parse.nodeids', 'canonical' );
- $graph->setAttribute( 'parse.nodes', $self->nodes() );
- $graph->setAttribute( 'parse.order', 'nodesfirst' );
+ # Add the collation graphs themselves
+ my $sgraph = $root->addNewChild( $graphml_ns, 'graph' );
+ $sgraph->setAttribute( 'edgedefault', 'directed' );
+ $sgraph->setAttribute( 'id', $self->tradition->name );
+ $sgraph->setAttribute( 'parse.edgeids', 'canonical' );
+ $sgraph->setAttribute( 'parse.edges', scalar($self->paths) );
+ $sgraph->setAttribute( 'parse.nodeids', 'canonical' );
+ $sgraph->setAttribute( 'parse.nodes', scalar($self->readings) );
+ $sgraph->setAttribute( 'parse.order', 'nodesfirst' );
+
+ my $rgraph;
+ if( scalar $self->relationships ) {
+ 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;
+ _add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
+ }
my $node_ctr = 0;
my %node_hash;
- foreach my $n ( $self->readings ) {
- my %this_node_data = ();
- foreach my $ndi ( 0 .. $#node_data ) {
- my $value;
- $this_node_data{'d'.$ndi} = $n->name if $node_data[$ndi] eq 'name';
- $this_node_data{'d'.$ndi} = $n->label
- if $node_data[$ndi] eq 'token';
- $this_node_data{'d'.$ndi} = $n->primary->name if $n->has_primary;
- $this_node_data{'d'.$ndi} =
- $self->{'positions'}->node_position( $n )
- if $node_data[$ndi] eq 'position';
- }
- my $node_el = $graph->addNewChild( $graphml_ns, 'node' );
- my $node_xmlid = 'n' . $node_ctr++;
- $node_hash{ $n->name } = $node_xmlid;
- $node_el->setAttribute( 'id', $node_xmlid );
-
- foreach my $dk ( keys %this_node_data ) {
- my $d_el = $node_el->addNewChild( $graphml_ns, 'data' );
- $d_el->setAttribute( 'key', $dk );
- $d_el->appendTextChild( $this_node_data{$dk} );
+ # Add our readings to the graphs
+ foreach my $n ( sort { $a->id cmp $b->id } $self->readings ) {
+ # Add to the main graph
+ my $node_el = $sgraph->addNewChild( $graphml_ns, 'node' );
+ my $node_xmlid = 'n' . $node_ctr++;
+ $node_hash{ $n->id } = $node_xmlid;
+ $node_el->setAttribute( 'id', $node_xmlid );
+ foreach my $d ( keys %node_data ) {
+ my $nval = $n->$d;
+ _add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
+ if defined $nval;
+ }
+ # Add to the relationships graph
+ if( $rgraph ) {
+ 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 ) ) {
+ my( $id, $from, $to ) = ( 'e'.$edge_ctr++,
+ $node_hash{ $e->[0] },
+ $node_hash{ $e->[1] } );
+ my $edge_el = $sgraph->addNewChild( $graphml_ns, 'edge' );
+ $edge_el->setAttribute( 'source', $from );
+ $edge_el->setAttribute( 'target', $to );
+ $edge_el->setAttribute( 'id', $id );
+
+ # It's a witness path, so add the witness
+ my $base = $wit;
+ my $key = $edge_data_keys{'witness'};
+ # Is this an ante-corr witness?
+ my $aclabel = $self->ac_label;
+ if( $wit =~ /^(.*)\Q$aclabel\E$/ ) {
+ # Keep the base witness
+ $base = $1;
+ # ...and record that this is an 'extra' reading path
+ _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
+ if( $rgraph ) {
+ 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_graphml_data( $edge_el, $edge_data_keys{'class'}, 'relationship' );
+ }
}
- foreach my $e ( $self->edges() ) {
- my( $name, $from, $to ) = ( $e->name,
- $node_hash{ $e->from()->name() },
- $node_hash{ $e->to()->name() } );
- my $edge_el = $graph->addNewChild( $graphml_ns, 'edge' );
- $edge_el->setAttribute( 'source', $from );
- $edge_el->setAttribute( 'target', $to );
- $edge_el->setAttribute( 'id', $name );
- # TODO Got to add the witnesses
+ # Save and return the thing
+ my $result = decode_utf8( $graphml->toString(1) );
+ return $result;
+}
+
+sub _add_graphml_data {
+ my( $el, $key, $value ) = @_;
+ return unless defined $value;
+ my $data_el = $el->addNewChild( $el->namespaceURI, 'data' );
+ $data_el->setAttribute( 'key', $key );
+ $data_el->appendText( $value );
+}
+
+=item B<as_csv>
+
+print $graph->as_csv( $recalculate )
+
+Returns a CSV alignment table representation of the collation graph, one
+row per witness (or witness uncorrected.)
+
+=cut
+
+sub as_csv {
+ my( $self ) = @_;
+ my $table = $self->make_alignment_table;
+ my $csv = Text::CSV_XS->new( { binary => 1, quote_null => 0 } );
+ my @result;
+ # Make the header row
+ $csv->combine( map { $_->{'witness'} } @{$table->{'alignment'}} );
+ push( @result, decode_utf8( $csv->string ) );
+ # Make the rest of the rows
+ foreach my $idx ( 0 .. $table->{'length'} - 1 ) {
+ my @rowobjs = map { $_->{'tokens'}->[$idx] } @{$table->{'alignment'}};
+ my @row = map { $_ ? $_->{'t'} : $_ } @rowobjs;
+ $csv->combine( @row );
+ push( @result, decode_utf8( $csv->string ) );
}
+ return join( "\n", @result );
+}
+
+=item B<make_alignment_table>
+
+my $table = $graph->make_alignment_table( $use_refs, \@wits_to_include )
+
+Return a reference to an alignment table, in a slightly enhanced CollateX
+format which looks like this:
+
+ $table = { alignment => [ { witness => "SIGIL",
+ tokens => [ { t => "READINGTEXT" }, ... ] },
+ { witness => "SIG2",
+ tokens => [ { t => "READINGTEXT" }, ... ] },
+ ... ],
+ 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
+keys have a true hash value will be included.
- # Return the thing
- $self->_save_graphml( $graphml );
- return $graphml;
+=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;
+ }
+ my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
+ my @all_pos = ( 1 .. $self->end->rank - 1 );
+ foreach my $wit ( $self->tradition->witnesses ) {
+ if( $include ) {
+ next unless $include->{$wit->sigil};
+ }
+ # print STDERR "Making witness row(s) for " . $wit->sigil . "\n";
+ my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
+ my @row = _make_witness_row( \@wit_path, \@all_pos, $noderefs );
+ push( @{$table->{'alignment'}},
+ { '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 );
+ 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 $table;
+}
+
+sub _make_witness_row {
+ my( $path, $positions, $noderefs ) = @_;
+ my %char_hash;
+ map { $char_hash{$_} = undef } @$positions;
+ my $debug = 0;
+ foreach my $rdg ( @$path ) {
+ my $rtext = $rdg->text;
+ $rtext = '#LACUNA#' if $rdg->is_lacuna;
+ print STDERR "rank " . $rdg->rank . "\n" if $debug;
+ # print STDERR "No rank for " . $rdg->id . "\n" unless defined $rdg->rank;
+ $char_hash{$rdg->rank} = $noderefs ? { 't' => $rdg }
+ : { 't' => $rtext };
+ }
+ my @row = map { $char_hash{$_} } @$positions;
+ # Fill in lacuna markers for undef spots in the row
+ my $last_el = shift @row;
+ my @filled_row = ( $last_el );
+ foreach my $el ( @row ) {
+ # If we are using node reference, make the lacuna node appear many times
+ # in the table. If not, use the lacuna tag.
+ if( $last_el && _el_is_lacuna( $last_el ) && !defined $el ) {
+ $el = $noderefs ? $last_el : { 't' => '#LACUNA#' };
+ }
+ push( @filled_row, $el );
+ $last_el = $el;
+ }
+ return @filled_row;
+}
+
+# Tiny utility function to say if a table element is a lacuna
+sub _el_is_lacuna {
+ my $el = shift;
+ return 1 if $el->{'t'} eq '#LACUNA#';
+ return 1 if ref( $el->{'t'} ) eq 'Text::Tradition::Collation::Reading'
+ && $el->{'t'}->is_lacuna;
+ return 0;
+}
+
+# Helper to turn the witnesses along columns rather than rows. Assumes
+# equal-sized rows.
+sub _turn_table {
+ my( $table ) = @_;
+ my $result = [];
+ return $result unless scalar @$table;
+ my $nrows = scalar @{$table->[0]};
+ foreach my $idx ( 0 .. $nrows - 1 ) {
+ foreach my $wit ( 0 .. $#{$table} ) {
+ $result->[$idx]->[$wit] = $table->[$wit]->[$idx];
+ }
+ }
+ return $result;
}
=back
Returns the beginning of the collation, a meta-reading with label '#START#'.
-=cut
+=item B<end>
+
+my $end = $collation->end();
+
+Returns the end of the collation, a meta-reading with label '#END#'.
-sub start {
- # Return the beginning reading of the graph.
- my $self = shift;
- my( $new_start ) = @_;
- if( $new_start ) {
- $self->del_reading( '#START#' );
- $self->graph->rename_node( $new_start, '#START#' );
- }
- return $self->reading('#START#');
-}
=item B<reading_sequence>
=cut
+# TODO Think about returning some lazy-eval iterator.
+
sub reading_sequence {
my( $self, $start, $end, $witness, $backup ) = @_;
- $witness = 'base text' unless $witness;
+ $witness = $self->baselabel unless $witness;
my @readings = ( $start );
my %seen;
my $n = $start;
- while( $n ne $end ) {
- if( exists( $seen{$n->name()} ) ) {
- warn "Detected loop at " . $n->name();
- last;
- }
- $seen{$n->name()} = 1;
-
- my $next = $self->next_reading( $n, $witness, $backup );
- warn "Did not find any path for $witness from reading " . $n->name
- unless $next;
- push( @readings, $next );
- $n = $next;
+ while( $n && $n->id ne $end->id ) {
+ if( exists( $seen{$n->id} ) ) {
+ warn "Detected loop at " . $n->id;
+ last;
+ }
+ $seen{$n->id} = 1;
+
+ my $next = $self->next_reading( $n, $witness, $backup );
+ unless( $next ) {
+ warn "Did not find any path for $witness from reading " . $n->id;
+ last;
+ }
+ push( @readings, $next );
+ $n = $next;
}
# Check that the last reading is our end reading.
my $last = $readings[$#readings];
- warn "Last reading found from " . $start->label() .
- " for witness $witness is not the end!"
- unless $last eq $end;
+ warn "Last reading found from " . $start->text .
+ " for witness $witness is not the end!"
+ unless $last->id eq $end->id;
return @readings;
}
my $next_reading = $graph->next_reading( $reading, $witpath );
Returns the reading that follows the given reading along the given witness
-path. TODO These are badly named.
+path.
=cut
sub next_reading {
# Return the successor via the corresponding path.
my $self = shift;
- return $self->_find_linked_reading( 'next', @_ );
+ my $answer = $self->_find_linked_reading( 'next', @_ );
+ return undef unless $answer;
+ return $self->reading( $answer );
}
=item B<prior_reading>
my $prior_reading = $graph->prior_reading( $reading, $witpath );
Returns the reading that precedes the given reading along the given witness
-path. TODO These are badly named.
+path.
=cut
sub prior_reading {
# Return the predecessor via the corresponding path.
my $self = shift;
- return $self->_find_linked_reading( 'prior', @_ );
+ my $answer = $self->_find_linked_reading( 'prior', @_ );
+ return $self->reading( $answer );
}
sub _find_linked_reading {
my( $self, $direction, $node, $path, $alt_path ) = @_;
my @linked_paths = $direction eq 'next'
- ? $node->outgoing() : $node->incoming();
+ ? $self->sequence->edges_from( $node )
+ : $self->sequence->edges_to( $node );
return undef unless scalar( @linked_paths );
# We have to find the linked path that contains all of the
# witnesses supplied in $path.
my( @path_wits, @alt_path_wits );
- @path_wits = $self->witnesses_of_label( $path ) if $path;
- @alt_path_wits = $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( $le->name eq 'base text' ) {
- $base_le = $le;
- } else {
- my @le_wits = $self->witnesses_of_label( $le->name );
- if( _is_within( \@path_wits, \@le_wits ) ) {
- # This is the right path.
- return $direction eq 'next' ? $le->to() : $le->from();
- } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
- $alt_le = $le;
- }
- }
+ if( $self->sequence->has_edge_attribute( @$le, $self->baselabel ) ) {
+ $base_le = $le;
+ }
+ my @le_wits = $self->path_witnesses( $le );
+ if( _is_within( \@path_wits, \@le_wits ) ) {
+ # This is the right path.
+ return $direction eq 'next' ? $le->[1] : $le->[0];
+ } elsif( _is_within( \@alt_path_wits, \@le_wits ) ) {
+ $alt_le = $le;
+ }
}
# Got this far? Return the alternate path if it exists.
- return $direction eq 'next' ? $alt_le->to() : $alt_le->from()
- if $alt_le;
+ return $direction eq 'next' ? $alt_le->[1] : $alt_le->[0]
+ if $alt_le;
# Got this far? Return the base path if it exists.
- return $direction eq 'next' ? $base_le->to() : $base_le->from()
- if $base_le;
+ return $direction eq 'next' ? $base_le->[1] : $base_le->[0]
+ if $base_le;
# Got this far? We have no appropriate path.
- warn "Could not find $direction node from " . $node->label
- . " along path $path";
+ warn "Could not find $direction node from " . $node->id
+ . " along path $path";
return undef;
}
# Some set logic.
sub _is_within {
my( $set1, $set2 ) = @_;
- my $ret = 1;
+ my $ret = @$set1; # will be 0, i.e. false, if set1 is empty
foreach my $el ( @$set1 ) {
- $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
+ $ret = 0 unless grep { /^\Q$el\E$/ } @$set2;
}
return $ret;
}
## INITIALIZATION METHODS - for use by parsers
-# Walk the paths for each witness in the graph, and return the nodes
-# that the graph has in common. If $using_base is true, some
-# different logic is needed.
-
-sub walk_witness_paths {
- my( $self, $end ) = @_;
- # For each witness, walk the path through the graph.
- # Then we need to find the common nodes.
- # TODO This method is going to fall down if we have a very gappy
- # text in the collation.
- my $paths = {};
- my @common_readings;
- foreach my $wit ( @{$self->tradition->witnesses} ) {
- my $curr_reading = $self->start;
- my @wit_path = $self->reading_sequence( $self->start, $end,
- $wit->sigil );
- $wit->path( \@wit_path );
-
- # Detect the common readings.
- if( @common_readings ) {
- my @cn;
- foreach my $n ( @wit_path ) {
- push( @cn, $n ) if grep { $_ eq $n } @common_readings;
- }
- @common_readings = ();
- push( @common_readings, @cn );
- } else {
- push( @common_readings, @wit_path );
- }
- }
- # Mark all the nodes as either common or not.
- foreach my $cn ( @common_readings ) {
- print STDERR "Setting " . $cn->name . " / " . $cn->label
- . " as common node\n";
- $cn->make_common;
- }
- foreach my $n ( $self->readings() ) {
- $n->make_variant unless $n->is_common;
+# 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.
+# When we are done, clear out the witness path attributes, as they are no
+# longer needed.
+# TODO Find a way to replace the witness path attributes with encapsulated functions?
+
+sub make_witness_paths {
+ my( $self ) = @_;
+ foreach my $wit ( $self->tradition->witnesses ) {
+ # print STDERR "Making path for " . $wit->sigil . "\n";
+ $self->make_witness_path( $wit );
}
- # Return an array of the common nodes in order.
- return @common_readings;
-}
-
-# An alternative to walk_witness_paths, for use when a collation is
-# constructed from a base text and an apparatus. Also modifies the
-# collation graph to remove all 'base text' paths and replace them
-# with real witness paths.
-
-sub walk_and_expand_base {
- my( $self, $end ) = @_;
-
- foreach my $wit ( @{$self->tradition->witnesses} ) {
- my $sig = $wit_sigil;
- my $post_sig;
- $post_sig = $wit->post_correctione
- if $wit->has_post_correctione;
- my @wit_path = ( $self->start );
- my @wit_pc_path;
- my $curr_rdg = $self->start;
- my %seen;
- while( $curr_rdg ne $end ) {
- if( $seen{$curr_reading->name} ) {
- warn "Detected loop in walk_and_expand_base with witness "
- . "$sig on reading " . $curr_reading->name . "\n";
- last;
- }
- my $next_rdg = $self->next_reading( $curr_reading, $sig );
- unless( $self->has_explicit_path( $curr_reading,
- $next_reading, $sig ) ) {
- $self->add_path( $curr_reading, $next_reading, $sig );
- }
- push( @wit_path, $next_reading );
- $seen{$curr_reading->name} = 1;
- }
- $wit->path( \@wit_path );
-
- # Now go through this path and look for p.c. divergences.
- # TODO decide how to handle p.c. paths
- # BIG TODO handle case where p.c. follows the base and a.c. doesn't!
-
-
}
-sub common_readings {
- my $self = shift;
- my @common = grep { $_->is_common } $self->readings();
- return sort { _cmp_position( $a->position, $b->position ) } @common;
-}
-
-# Calculate the relative positions of nodes in the graph, if they
-# were not given to us.
-sub calculate_positions {
- my( $self, @ordered_common ) = @_;
-
- # We have to calculate the position identifiers for each word,
- # keyed on the common nodes. This will be 'fun'. The end result
- # is a hash per witness, whose key is the word node and whose
- # value is its position in the text. Common nodes are always N,1
- # so have identical positions in each text.
-
- my $node_pos = {};
- foreach my $wit ( @{$self->tradition->witnesses} ) {
- # First we walk each path, making a matrix for each witness that
- # corresponds to its eventual position identifier. Common nodes
- # always start a new row, and are thus always in the first column.
-
- my $wit_matrix = [];
- my $cn = 0; # We should hit the common readings in order.
- my $row = [];
- foreach my $wn ( @{$wit->path} ) {
- if( $wn eq $ordered_common[$cn] ) {
- # Set up to look for the next common node, and
- # start a new row of words.
- $cn++;
- push( @$wit_matrix, $row ) if scalar( @$row );
- $row = [];
- }
- push( @$row, $wn );
- }
- push( @$wit_matrix, $row ); # Push the last row onto the matrix
-
- # Now we have a matrix per witness, so that each row in the
- # matrix begins with a common node, and continues with all the
- # variant words that appear in the witness. We turn this into
- # real positions in row,cell format. But we need some
- # trickery in order to make sure that each node gets assigned
- # to only one position.
-
- foreach my $li ( 1..scalar(@$wit_matrix) ) {
- foreach my $di ( 1..scalar(@{$wit_matrix->[$li-1]}) ) {
- my $reading = $wit_matrix->[$li-1]->[$di-1];
- my $position = "$li,$di";
- # If we have seen this node before, we need to compare
- # its position with what went before.
- unless( $reading->has_position &&
- _cmp_position( $position, $reading->position ) < 1 ) {
- # The new position ID replaces the old one.
- $reading->position( $position );
- } # otherwise, the old position needs to stay.
- }
- }
+sub make_witness_path {
+ my( $self, $wit ) = @_;
+ my @chain = @{$wit->path};
+ my $sig = $wit->sigil;
+ foreach my $idx ( 0 .. $#chain-1 ) {
+ $self->add_path( $chain[$idx], $chain[$idx+1], $sig );
}
-
- $self->init_lemmata();
-}
-
-sub _cmp_position {
- my( $a, $b ) = @_;
- if ( $a && $b ) {
- my @pos_a = split(/,/, $a );
- my @pos_b = split(/,/, $b );
-
- my $big_cmp = $pos_a[0] <=> $pos_b[0];
- return $big_cmp if $big_cmp;
- # else
- return $pos_a[1] <=> $pos_b[1];
- } elsif ( $b ) { # a is undefined
- return -1;
- } elsif ( $a ) { # b is undefined
- return 1;
+ if( $wit->is_layered ) {
+ @chain = @{$wit->uncorrected_path};
+ foreach my $idx( 0 .. $#chain-1 ) {
+ my $source = $chain[$idx];
+ my $target = $chain[$idx+1];
+ $self->add_path( $source, $target, $sig.$self->ac_label )
+ unless $self->has_path( $source, $target, $sig );
+ }
}
- return 0; # they are both undefined
+ $wit->clear_path;
+ $wit->clear_uncorrected_path;
}
-sub all_positions {
+sub calculate_ranks {
my $self = shift;
- my %positions = ();
- map { $positions{$_->position} = 1 } $self->readings;
- my @answer = sort { _cmp_position( $a, $b ) } keys( %positions );
- return @answer;
-}
-
-sub readings_at_position {
- my( $self, $pos ) = @_;
- my @answer = grep { $_->position eq $pos } $self->readings;
- return @answer;
-}
-
-## Lemmatizer functions
+ # Walk a version of the graph where every node linked by a relationship
+ # edge is fundamentally the same node, and do a topological ranking on
+ # the nodes in this graph.
+ my $topo_graph = Graph->new();
+ my %rel_containers;
+ my $rel_ctr = 0;
+ # Add the nodes
+ foreach my $r ( $self->readings ) {
+ next if exists $rel_containers{$r->id};
+ my @rels = $r->related_readings( 'colocated' );
+ if( @rels ) {
+ # Make a relationship container.
+ push( @rels, $r );
+ my $rn = 'rel_container_' . $rel_ctr++;
+ $topo_graph->add_vertex( $rn );
+ foreach( @rels ) {
+ $rel_containers{$_->id} = $rn;
+ }
+ } else {
+ # Add a new node to mirror the old node.
+ $rel_containers{$r->id} = $r->id;
+ $topo_graph->add_vertex( $r->id );
+ }
+ }
-sub init_lemmata {
- my $self = shift;
+ # Add the edges.
+ foreach my $r ( $self->readings ) {
+ foreach my $n ( $self->sequence->successors( $r->id ) ) {
+ my( $tfrom, $tto ) = ( $rel_containers{$r->id},
+ $rel_containers{$n} );
+ $DB::single = 1 unless $tfrom && $tto;
+ $topo_graph->add_edge( $tfrom, $tto );
+ }
+ }
- foreach my $position ( $self->all_positions ) {
- $self->lemmata->{$position} = undef;
+ # Now do the rankings, starting with the start node.
+ my $topo_start = $rel_containers{$self->start->id};
+ my $node_ranks = { $topo_start => 0 };
+ my @curr_origin = ( $topo_start );
+ # A little iterative function.
+ while( @curr_origin ) {
+ @curr_origin = _assign_rank( $topo_graph, $node_ranks, @curr_origin );
}
-
- foreach my $cr ( $self->common_readings ) {
- $self->lemmata->{$cr->position} = $cr->name;
+ # Transfer our rankings from the topological graph to the real one.
+ foreach my $r ( $self->readings ) {
+ 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?";
+ }
}
}
-
-=item B<lemma_readings>
-
-my @state = $graph->lemma_readings( @readings_delemmatized );
-
-Takes a list of readings that have just been delemmatized, and returns
-a set of tuples of the form ['reading', 'state'] that indicates what
-changes need to be made to the graph.
-
-=over
-
-=item *
-
-A state of 1 means 'lemmatize this reading'
-
-=item *
-
-A state of 0 means 'delemmatize this reading'
-
-=item *
-
-A state of undef means 'an ellipsis belongs in the text here because
-no decision has been made / an earlier decision was backed out'
-
-=back
-=cut
-
-sub lemma_readings {
- my( $self, @toggled_off_nodes ) = @_;
-
- # First get the positions of those nodes which have been
- # toggled off.
- my $positions_off = {};
- map { $positions_off->{ $_->position } = $_->name } @toggled_off_nodes;
-
- # Now for each position, we have to see if a node is on, and we
- # have to see if a node has been turned off.
- my @answer;
- foreach my $pos ( $self->all_positions() ) {
- # Find the state of this position. If there is an active node,
- # its name will be the state; otherwise the state will be 0
- # (nothing at this position) or undef (ellipsis at this position)
- my $active = $self->lemmata->{$pos};
-
- # Is there a formerly active node that was toggled off?
- if( exists( $positions_off->{$pos} ) ) {
- my $off_node = $positions_off->{$pos};
- if( $active && $active ne $off_node) {
- push( @answer, [ $off_node, 0 ], [ $active, 1 ] );
- } else {
- push( @answer, [ $off_node, $active ] );
- }
-
- # No formerly active node, so we just see if there is a currently
- # active one.
- } elsif( $active ) {
- # Push the active node, whatever it is.
- push( @answer, [ $active, 1 ] );
- } else {
- # Push the state that is there. Arbitrarily use the first node
- # at that position.
- my @pos_nodes = $self->readings_at_position( $pos );
- push( @answer, [ $pos_nodes[0]->name, $self->lemmata->{$pos} ] );
- }
+sub _assign_rank {
+ my( $graph, $node_ranks, @current_nodes ) = @_;
+ # Look at each of the children of @current_nodes. If all the child's
+ # parents have a rank, assign it the highest rank + 1 and add it to
+ # @next_nodes. Otherwise skip it; we will return when the highest-ranked
+ # parent gets a rank.
+ my @next_nodes;
+ foreach my $c ( @current_nodes ) {
+ warn "Current reading $c has no rank!"
+ unless exists $node_ranks->{$c};
+ # print STDERR "Looking at child of node $c, rank "
+ # . $node_ranks->{$c} . "\n";
+ foreach my $child ( $graph->successors( $c ) ) {
+ next if exists $node_ranks->{$child};
+ my $highest_rank = -1;
+ my $skip = 0;
+ foreach my $parent ( $graph->predecessors( $child ) ) {
+ if( exists $node_ranks->{$parent} ) {
+ $highest_rank = $node_ranks->{$parent}
+ if $highest_rank <= $node_ranks->{$parent};
+ } else {
+ $skip = 1;
+ last;
+ }
+ }
+ next if $skip;
+ my $c_rank = $highest_rank + 1;
+ # print STDERR "Assigning rank $c_rank to node $child \n";
+ $node_ranks->{$child} = $c_rank;
+ push( @next_nodes, $child );
+ }
}
-
- return @answer;
+ return @next_nodes;
}
-=item B<toggle_reading>
-
-my @readings_delemmatized = $graph->toggle_reading( $reading_name );
-
-Takes a reading node name, and either lemmatizes or de-lemmatizes
-it. Returns a list of all readings that are de-lemmatized as a result
-of the toggle.
-
-=cut
-
-sub toggle_reading {
- my( $self, $rname ) = @_;
-
- return unless $rname;
- my $reading = $self->reading( $rname );
- if( !$reading || $reading->is_common() ) {
- # Do nothing, it's a common node.
- return;
- }
-
- my $pos = $reading->position;
- my $old_state = $self->lemmata->{$pos};
- my @readings_off;
- if( $old_state && $old_state eq $rname ) {
- # Turn off the node. We turn on no others by default.
- push( @readings_off, $reading );
- } else {
- # Turn on the node.
- $self->lemmata->{$pos} = $rname;
- # Any other 'on' readings in the same position should be off.
- push( @readings_off, $self->same_position_as( $reading ) );
- # Any node that is an identical transposed one should be off.
- push( @readings_off, $reading->identical_readings );
- }
- @readings_off = unique_list( @readings_off );
-
- # Turn off the readings that need to be turned off.
- my @readings_delemmatized;
- foreach my $n ( @readings_off ) {
- my $state = $self->lemmata->{$n->position};
- if( $state && $state eq $n->name ) {
- # this reading is still on, so turn it off
- push( @readings_delemmatized, $n );
- my $new_state = undef;
- if( $n eq $reading ) {
- # This is the reading that was clicked, so if there are no
- # other readings there, turn off the position. In all other
- # cases, restore the ellipsis.
- my @other_n = $self->same_position_as( $n );
- $new_state = 0 unless @other_n;
- }
- $self->lemmata->{$n->position} = $new_state;
- } elsif( $old_state && $old_state eq $n->name ) {
- # another reading has already been turned on here
- push( @readings_delemmatized, $n );
- } # else some other reading was on anyway, so pass.
+# Another method to make up for rough collation methods. If the same reading
+# appears multiple times at the same rank, collapse the nodes.
+sub flatten_ranks {
+ my $self = shift;
+ my %unique_rank_rdg;
+ foreach my $rdg ( $self->readings ) {
+ next unless $rdg->has_rank;
+ my $key = $rdg->rank . "||" . $rdg->text;
+ if( exists $unique_rank_rdg{$key} ) {
+ # Combine!
+ # print STDERR "Combining readings at same rank: $key\n";
+ $self->merge_readings( $unique_rank_rdg{$key}, $rdg );
+ } else {
+ $unique_rank_rdg{$key} = $rdg;
+ }
}
- return @readings_delemmatized;
}
-sub same_position_as {
- my( $self, $reading ) = @_;
- my $pos = $reading->position;
- my @same = grep { $_ ne $reading } $self->readings_at_position( $reading->position );
- return @same;
-}
+## Utility functions
+
# Return the string that joins together a list of witnesses for
# display on a single path.
-sub path_label {
- my $self = shift;
- return join( $self->wit_list_separator, @_ );
-}
-
sub witnesses_of_label {
my( $self, $label ) = @_;
my $regex = $self->wit_list_separator;
return @answer;
}
-sub unique_list {
- my( @list ) = @_;
- my %h;
- map { $h{$_->name} = $_ } @list;
- return values( %h );
-}
-
no Moose;
__PACKAGE__->meta->make_immutable;
+
+=head1 BUGS / TODO
+
+=over
+
+=item * Think about making Relationship objects again
+
+=back
projects / scpubgit/stemmatology.git / blobdiff