ok( $c->reading( 'n21p0' ), "New reading exists" );
is( scalar $c->readings, $rno, "Reading add offset by flatten_ranks" );
-# Combine n3 and n4
+# Combine n3 and n4 ( with his )
$c->merge_readings( 'n3', 'n4', 1 );
ok( !$c->reading('n4'), "Reading n4 is gone" );
is( $c->reading('n3')->text, 'with his', "Reading n3 has both words" );
-# Collapse n25 and n26
-$c->merge_readings( 'n25', 'n26' );
-ok( !$c->reading('n26'), "Reading n26 is gone" );
-is( $c->reading('n25')->text, 'rood', "Reading n25 has an unchanged word" );
+# Collapse n9 and n10 ( rood / root )
+$c->merge_readings( 'n9', 'n10' );
+ok( !$c->reading('n10'), "Reading n10 is gone" );
+is( $c->reading('n9')->text, 'rood', "Reading n9 has an unchanged word" );
# Combine n21 and n21p0
my $remaining = $c->reading('n21');
my $color_common = $opts->{'color_common'} if $opts;
my $STRAIGHTENHACK = !$startrank && !$endrank && $self->end->rank
&& $self->end->rank > 100;
+ $STRAIGHTENHACK = 1 if $opts->{'straight'}; # even for subgraphs or small graphs
# Check the arguments
if( $startrank ) {
}
if( $STRAIGHTENHACK ) {
## HACK part 1
- $dot .= "\tsubgraph { rank=same \"#START#\" \"#SILENT#\" }\n";
+ my $startlabel = $startrank ? 'SUBSTART' : 'START';
+ $dot .= "\tsubgraph { rank=same \"#$startlabel#\" \"#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
}
# HACK part 2
if( $STRAIGHTENHACK ) {
- $dot .= "\t\"#END#\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
+ my $endlabel = $endrank ? 'SUBEND' : 'END';
+ $dot .= "\t\"#$endlabel#\" -> \"#SILENT#\" [ color=white,penwidth=0 ];\n";
}
$dot .= "}\n";
return @wits;
}
+# Helper function. Make a display label for the given witnesses, showing a.c.
+# witnesses only where the main witness is not also in the list.
sub _path_display_label {
my $self = shift;
- my @wits = sort @_;
+ my %wits;
+ map { $wits{$_} = 1 } @_;
+
+ # If an a.c. wit is listed, remove it if the main wit is also listed.
+ # Otherwise keep it for explicit listing.
+ my $aclabel = $self->ac_label;
+ my @disp_ac;
+ foreach my $w ( sort keys %wits ) {
+ if( $w =~ /^(.*)\Q$aclabel\E$/ ) {
+ if( exists $wits{$1} ) {
+ delete $wits{$w};
+ } else {
+ push( @disp_ac, $w );
+ }
+ }
+ }
+
+ # See if we are in a majority situation.
my $maj = scalar( $self->tradition->witnesses ) * 0.6;
- if( scalar @wits > $maj ) {
- # TODO break out a.c. wits
- return 'majority';
+ if( scalar keys %wits > $maj ) {
+ unshift( @disp_ac, 'majority' );
+ return join( ', ', @disp_ac );
} else {
- return join( ', ', @wits );
+ return join( ', ', sort keys %wits );
}
}
-=head2 witnesses_at_rank
+=head2 readings_at_rank( $rank )
-Returns a list of witnesses that are not lacunose, for a given rank.
+Returns a list of readings at a given rank, taken from the alignment table.
=cut
-sub witnesses_at_rank {
+sub readings_at_rank {
my( $self, $rank ) = @_;
+ my $table = $self->alignment_table;
+ # Table rank is real rank - 1.
+ my @elements = map { $_->{'tokens'}->[$rank-1] } @{$table->{'alignment'}};
+ my %readings;
+ foreach my $e ( @elements ) {
+ next unless ref( $e ) eq 'HASH';
+ next unless exists $e->{'t'};
+ $readings{$e->{'t'}->id} = $e->{'t'};
+ }
+ return values %readings;
}
=head2 as_graphml
$graphml->setDocumentElement( $root );
$root->setNamespace( $xsi_ns, 'xsi', 0 );
$root->setAttributeNS( $xsi_ns, 'schemaLocation', $graphml_schema );
+
+ # List of attribute types to save on our objects and their corresponding
+ # GraphML types
+ my %save_types = (
+ 'Str' => 'string',
+ 'Int' => 'int',
+ 'Bool' => 'boolean',
+ 'RelationshipType' => 'string',
+ 'RelationshipScope' => 'string',
+ );
+
+ # List of attribute names *not* to save on our objects.
+ # We will also not save any attribute beginning with _.
+ my %skipsave;
+ map { $skipsave{$_} = 1 } qw/ cached_svg /;
- # Add the data keys for the graph
+ # Add the data keys for the graph. Include an extra key 'version' for the
+ # GraphML output version.
my %graph_data_keys;
my $gdi = 0;
- my @graph_attributes = qw/ version wit_list_separator baselabel linear ac_label /;
- foreach my $datum ( @graph_attributes ) {
+ my %graph_attributes = ( 'version' => 'string' );
+ # Graph attributes include those of Tradition and those of Collation.
+ my %gattr_from;
+ my $tmeta = $self->tradition->meta;
+ my $cmeta = $self->meta;
+ map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
+ map { $gattr_from{$_->name} = 'Collation' } $cmeta->get_all_attributes;
+ foreach my $attr ( ( $tmeta->get_all_attributes, $cmeta->get_all_attributes ) ) {
+ next if $attr->name =~ /^_/;
+ next if $skipsave{$attr->name};
+ next unless $save_types{$attr->type_constraint->name};
+ $graph_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
+ }
+
+ foreach my $datum ( sort keys %graph_attributes ) {
$graph_data_keys{$datum} = 'dg'.$gdi++;
my $key = $root->addNewChild( $graphml_ns, 'key' );
$key->setAttribute( 'attr.name', $datum );
- $key->setAttribute( 'attr.type', $datum eq 'linear' ? 'boolean' : 'string' );
+ $key->setAttribute( 'attr.type', $graph_attributes{$datum} );
$key->setAttribute( 'for', 'graph' );
$key->setAttribute( 'id', $graph_data_keys{$datum} );
}
- # Add the data keys for nodes
+ # Add the data keys for reading nodes
+ my %reading_attributes;
+ my $rmeta = Text::Tradition::Collation::Reading->meta;
+ foreach my $attr( $rmeta->get_all_attributes ) {
+ next if $attr->name =~ /^_/;
+ next if $skipsave{$attr->name};
+ next unless $save_types{$attr->type_constraint->name};
+ $reading_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
+ }
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',
- is_common => 'boolean',
- join_prior => 'boolean',
- join_next => 'boolean',
- );
- foreach my $datum ( keys %node_data ) {
+ foreach my $datum ( sort keys %reading_attributes ) {
$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( 'attr.type', $reading_attributes{$datum} );
$key->setAttribute( 'for', 'node' );
$key->setAttribute( 'id', $node_data_keys{$datum} );
}
- # Add the data keys for edges, i.e. witnesses
+ # Add the data keys for edges, that is, paths and relationships. Path
+ # data does not come from a Moose class so is here manually.
my $edi = 0;
my %edge_data_keys;
- my %edge_data = (
- class => 'string', # Class, deprecated soon
+ my %edge_attributes = (
witness => 'string', # ID/label for a path
- relationship => 'string', # ID/label for a relationship
extra => 'boolean', # Path key
- scope => 'string', # Relationship key
- annotation => 'string', # Relationship key
- non_correctable => 'boolean', # Relationship key
- non_independent => 'boolean', # Relationship key
);
- foreach my $datum ( keys %edge_data ) {
+ my @path_attributes = keys %edge_attributes; # track our manual additions
+ my $pmeta = Text::Tradition::Collation::Relationship->meta;
+ foreach my $attr( $pmeta->get_all_attributes ) {
+ next if $attr->name =~ /^_/;
+ next if $skipsave{$attr->name};
+ next unless $save_types{$attr->type_constraint->name};
+ $edge_attributes{$attr->name} = $save_types{$attr->type_constraint->name};
+ }
+ foreach my $datum ( sort keys %edge_attributes ) {
$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( 'attr.type', $edge_attributes{$datum} );
$key->setAttribute( 'for', 'edge' );
$key->setAttribute( 'id', $edge_data_keys{$datum} );
}
$sgraph->setAttribute( 'parse.order', 'nodesfirst' );
# Collation attribute data
- foreach my $datum ( @graph_attributes ) {
- my $value = $datum eq 'version' ? '3.0' : $self->$datum;
+ foreach my $datum ( keys %graph_attributes ) {
+ my $value;
+ if( $datum eq 'version' ) {
+ $value = '3.1';
+ } elsif( $gattr_from{$datum} eq 'Tradition' ) {
+ $value = $self->tradition->$datum;
+ } else {
+ $value = $self->$datum;
+ }
_add_graphml_data( $sgraph, $graph_data_keys{$datum}, $value );
}
my $node_xmlid = 'n' . $node_ctr++;
$node_hash{ $n->id } = $node_xmlid;
$node_el->setAttribute( 'id', $node_xmlid );
- foreach my $d ( keys %node_data ) {
+ foreach my $d ( keys %reading_attributes ) {
my $nval = $n->$d;
_add_graphml_data( $node_el, $node_data_keys{$d}, $nval )
if defined $nval;
_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 graph to the XML
+ map { delete $edge_data_keys{$_} } @path_attributes;
$self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
$node_data_keys{'id'}, \%edge_data_keys );
is( $c->alignment_table, $table, "Cached table returned upon second call" );
$c->calculate_ranks;
is( $c->alignment_table, $table, "Cached table retained with no rank change" );
-$c->add_relationship( 'n9', 'n23', { 'type' => 'spelling' } );
+$c->add_relationship( 'n24', 'n23', { 'type' => 'spelling' } );
isnt( $c->alignment_table, $table, "Alignment table changed after relationship add" );
=end testing
sub flatten_ranks {
my $self = shift;
my %unique_rank_rdg;
+ my $changed;
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";
+ $changed = 1;
$self->merge_readings( $unique_rank_rdg{$key}, $rdg );
# TODO see if this now makes a common point.
} else {
$unique_rank_rdg{$key} = $rdg;
}
}
+ # If we merged readings, the ranks are still fine but the alignment
+ # table is wrong. Wipe it.
+ $self->wipe_table() if $changed;
}
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 /;
+my @expected = qw/ n1 n11 n16 n19 n20 n5 n6 n7 /;
is_deeply( \@marked, \@expected, "Found correct list of common readings" );
=end testing
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 ) );
+ my @readings = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
+ my @text;
+ foreach my $r ( @readings ) {
+ next if $r->is_meta;
+ push( @text, $r->text );
+ }
$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 );
+ my @ucrdgs = $self->reading_sequence( $self->start, $self->end,
+ $wit->sigil.$self->ac_label );
+ my @uctext;
+ foreach my $r ( @ucrdgs ) {
+ next if $r->is_meta;
+ push( @uctext, $r->text );
+ }
+ $wit->layertext( \@uctext );
}
}
}
);
my $c = $t->collation;
-is( $c->common_predecessor( 'n9', 'n23' )->id,
+is( $c->common_predecessor( 'n24', 'n23' )->id,
'n20', "Found correct common predecessor" );
-is( $c->common_successor( 'n9', 'n23' )->id,
+is( $c->common_successor( 'n24', '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,
+is( $c->common_successor( 'n21', 'n10' )->id,
'#END#', "Found correct common successor for readings on same path" );
=end testing