is( scalar @v2, 2, "Added a global relationship with two instances" );
@v1 = $c->del_relationship( 'n22', 'n21' );
is( scalar @v1, 1, "Deleted first relationship" );
-@v2 = $c->del_relationship( 'n12', 'n13' );
+@v2 = $c->del_relationship( 'n12', 'n13', 1 );
is( scalar @v2, 2, "Deleted second global relationship" );
my @v3 = $c->del_relationship( 'n1', 'n2' );
is( scalar @v3, 0, "Nothing deleted on non-existent relationship" );
+my @v4 = $c->add_relationship( 'n24', 'n23',
+ { 'type' => 'spelling', 'scope' => 'global' } );
+is( @v4, 2, "Re-added global relationship" );
+@v4 = $c->del_relationship( 'n12', 'n13' );
+is( @v4, 1, "Only specified relationship deleted this time" );
+ok( $c->get_relationship( 'n24', 'n23' ), "Other globally-added relationship exists" );
=end testing
handles => {
has_type => 'exists',
add_type => 'set',
+ del_type => 'delete',
type => 'get',
- del_type => 'delete'
+ types => 'values'
},
);
my $self = shift;
my @DEFAULT_TYPES = (
- { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0, is_generalizable => 0 },
- { name => 'orthographic', bindlevel => 0, use_regular => 0 },
- { name => 'spelling', bindlevel => 1 },
- { name => 'punctuation', bindlevel => 2 },
- { name => 'grammatical', bindlevel => 2 },
- { name => 'lexical', bindlevel => 2 },
- { name => 'uncertain', bindlevel => 50, is_transitive => 0, is_generalizable => 0 },
- { name => 'other', bindlevel => 50, is_transitive => 0, is_generalizable => 0 },
- { name => 'transposition', bindlevel => 50, is_colocation => 0 },
- { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0 }
+ { name => 'collated', bindlevel => 50, is_weak => 1, is_transitive => 0,
+ is_generalizable => 0, description => 'Internal use only' },
+ { name => 'orthographic', bindlevel => 0, use_regular => 0,
+ description => 'These are the same reading, neither unusually spelled.' },
+ { name => 'punctuation', bindlevel => 0,
+ description => 'These are the same reading apart from punctuation.' },
+ { name => 'spelling', bindlevel => 1,
+ description => 'These are the same reading, spelled differently.' },
+ { name => 'grammatical', bindlevel => 2,
+ description => 'These readings share a root (lemma), but have different parts of speech (morphologies).' },
+ { name => 'lexical', bindlevel => 2,
+ description => 'These readings share a part of speech (morphology), but have different roots (lemmata).' },
+ { name => 'uncertain', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
+ use_regular => 0, description => 'These readings are related, but a clear category cannot be assigned.' },
+ { name => 'other', bindlevel => 0, is_transitive => 0, is_generalizable => 0,
+ description => 'These readings are related in a way not covered by the existing types.' },
+ { name => 'transposition', bindlevel => 50, is_colocation => 0,
+ description => 'This is the same (or nearly the same) reading in a different location.' },
+ { name => 'repetition', bindlevel => 50, is_colocation => 0, is_transitive => 0,
+ description => 'This is a reading that was repeated in one or more witnesses.' }
);
foreach my $type ( @DEFAULT_TYPES ) {
my $edge = shift;
@vector = @$edge;
} else {
- @vector = @_;
+ @vector = @_[0,1];
}
my $relationship;
if( $self->graph->has_edge_attribute( @vector, 'object' ) ) {
# Test group 5: relationship transitivity.
my $t5 = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/john.xml' );
my $c5 = $t5->collation;
+# Test 5.0: propagate all existing transitive rels and make sure it succeeds
+my $orignumrels = scalar $c5->relationships();
+try {
+ $c5->relations->propagate_all_relationships();
+ ok( 1, "Propagated all existing transitive relationships" );
+} catch ( Text::Tradition::Error $err ) {
+ ok( 0, "Failed to propagate all existing relationships: " . $err->message );
+}
+ok( scalar( $c5->relationships ) > $orignumrels, "Added some relationships in propagation" );
# Test 5.1: make a grammatical link to an orthographically-linked reading
$c5->add_relationship( 'r13.5', 'r13.2', { type => 'orthographic' } );
}
}
-# Test 5.4: add a parallel but not sibling relationship
+# Test 5.4: delete a spelling relationship, add it again, make sure it doesn't
+# throw and make sure all the relationships are the same
+my $numrel = scalar $c5->relationships;
+$c5->del_relationship( 'r13.4', 'r13.2' );
+try {
+ $c5->add_relationship( 'r13.4', 'r13.2', { type => 'spelling', propagate => 1 } );
+ ok( 1, "Managed not to throw an exception re-adding the relationship" );
+} catch( Text::Tradition::Error $e ) {
+ ok( 0, "Threw an exception trying to re-add our intermediate relationship: " . $e->message );
+}
+is( $numrel, scalar $c5->relationships, "Number of relationships did not change" );
+foreach my $rdg ( qw/ r13.2 r13.3 r13.5 / ) {
+ my $newspel = $c5->get_relationship( 'r13.4', $rdg );
+ ok( $newspel, 'Relationship was made between indirectly linked readings' );
+ if( $newspel ) {
+ is( $newspel->type, 'spelling', 'Reinstated intermediate-in relationship has the correct type' );
+ }
+}
+my $stillgram = $c5->get_relationship( 'r13.4', 'r13.1' );
+ok( $stillgram, 'Relationship was made between indirectly linked readings' );
+if( $stillgram ) {
+ is( $stillgram->type, 'grammatical', 'Reinstated intermediate-out relationship has the correct type' );
+}
+
+# Test 5.5: add a parallel but not sibling relationship
$c5->add_relationship( 'r13.6', 'r13.2', { type => 'lexical', propagate => 1 } );
ok( !$c5->get_relationship( 'r13.6', 'r13.1' ),
"Lexical relationship did not affect grammatical" );
}
}
-# Test 5.5: try it with non-colocated relationships
-my $numrel = scalar $c5->relationships;
+# Test 5.6: try it with non-colocated relationships
+$numrel = scalar $c5->relationships;
$c5->add_relationship( 'r62.1', 'r64.1', { type => 'transposition', propagate => 1 } );
is( scalar $c5->relationships, $numrel+1,
"Adding non-colo relationship did not propagate" );
is( scalar $c5->relationships, $numrel+4,
"Adding non-colo relationship only propagated on non-colos" );
+# Test 5.7: ensure that attempts to cross boundaries on bindlevel-equal
+# relationships fail.
+try {
+ $c5->add_relationship( 'r39.6', 'r41.1', { type => 'grammatical', propagate => 1 } );
+ ok( 0, "Did not prevent add of conflicting relationship level" );
+} catch( Text::Tradition::Error $err ) {
+ like( $err->message, qr/Conflicting existing relationship/, "Got correct error message trying to add conflicting relationship level" );
+}
+
+# Test 5.8: ensure that weak relationships don't interfere
+$c5->add_relationship( 'r50.1', 'r50.2', { type => 'collated' } );
+$c5->add_relationship( 'r50.3', 'r50.4', { type => 'orthographic' } );
+try {
+ $c5->add_relationship( 'r50.4', 'r50.1', { type => 'grammatical', propagate => 1 } );
+ ok( 1, "Collation did not interfere with new relationship add" );
+} catch( Text::Tradition::Error $err ) {
+ ok( 0, "Collation interfered with new relationship add: " . $err->message );
+}
+my $crel = $c5->get_relationship( 'r50.1', 'r50.2' );
+ok( $crel, "Original relationship still exists" );
+if( $crel ) {
+ is( $crel->type, 'collated', "Original relationship still a collation" );
+}
+
+try {
+ $c5->add_relationship( 'r50.1', 'r51.1', { type => 'spelling', propagate => 1 } );
+ ok( 1, "Collation did not interfere with relationship re-ranking" );
+} catch( Text::Tradition::Error $err ) {
+ ok( 0, "Collation interfered with relationship re-ranking: " . $err->message );
+}
+$crel = $c5->get_relationship( 'r50.1', 'r50.2' );
+ok( !$crel, "Collation relationship now gone" );
+
+# Test 5.9: ensure that strong non-transitive relationships don't interfere
+$c5->add_relationship( 'r66.1', 'r66.4', { type => 'grammatical' } );
+$c5->add_relationship( 'r66.2', 'r66.4', { type => 'uncertain', propagate => 1 } );
+try {
+ $c5->add_relationship( 'r66.1', 'r66.3', { type => 'grammatical', propagate => 1 } );
+ ok( 1, "Non-transitive relationship did not block grammatical add" );
+} catch( Text::Tradition::Error $err ) {
+ ok( 0, "Non-transitive relationship blocked grammatical add: " . $err->message );
+}
+is( scalar $c5->related_readings( 'r66.4' ), 3, "Reading 66.4 has all its links" );
+is( scalar $c5->related_readings( 'r66.2' ), 1, "Reading 66.2 has only one link" );
+is( scalar $c5->related_readings( 'r66.1' ), 2, "Reading 66.1 has all its links" );
+is( scalar $c5->related_readings( 'r66.3' ), 2, "Reading 66.3 has all its links" );
=end testing
# Find all the pairs for which we need to set the relationship.
if( $relationship->colocated && $relationship->nonlocal && !$thispaironly ) {
my @global_set = $self->add_global_relationship( $relationship );
- map { push( @$_, $relationship->type ) } @global_set;
push( @pairs_set, @global_set );
}
if( $propagate ) {
return @vectors;
}
-=head2 del_relationship( $source, $target )
+=head2 del_relationship( $source, $target, $allscope )
Removes the relationship between the given readings. If the relationship is
-non-local, removes the relationship everywhere in the graph.
+non-local and $allscope is true, removes the relationship throughout the
+relevant scope.
=cut
sub del_relationship {
- my( $self, $source, $target ) = @_;
+ my( $self, $source, $target, $allscope ) = @_;
my $rel = $self->get_relationship( $source, $target );
return () unless $rel; # Nothing to delete; return an empty set.
my $reltype = $self->type( $rel->type );
my $colo = $rel->colocated;
my @vectors = ( [ $source, $target ] );
$self->_remove_relationship( $colo, $source, $target );
- if( $rel->nonlocal ) {
+ if( $rel->nonlocal && $allscope ) {
# Remove the relationship wherever it occurs.
my @rel_edges = grep { $self->get_relationship( @$_ ) eq $rel }
$self->relationships;
}
}
+=head2 verify_or_delete( $reading1, $reading2 ) {
+
+Given the existing relationship at ( $reading1, $reading2 ), make sure it is
+still valid. If it is not still valid, delete it. Use this only to check
+non-colocated relationships!
+
+=cut
+
+sub verify_or_delete {
+ my( $self, @vector ) = @_;
+ my $rel = $self->get_relationship( @vector );
+ throw( "You should not now be verifying colocated relationships!" )
+ if $rel->colocated;
+ my( $ok, $reason ) = $self->relationship_valid( @vector, $rel->type );
+ unless( $ok ) {
+ $self->del_relationship( @vector );
+ }
+}
+
+
=head2 related_readings( $reading, $filter )
Returns a list of readings that are connected via direct relationship links
my $r = shift @samelevel;
foreach my $nr ( @samelevel ) {
my $existing = $self->get_relationship( $r, $nr );
+ my $skip;
if( $existing ) {
- # Check that it's a matching type
- throw( "Conflicting existing relationship at $r, $nr trying to propagate "
- . $relobj->type . " relationship at @$rel" )
- unless $existing->type eq $relobj->type;
- } else {
+ my $extype = $self->type( $existing->type );
+ unless( $extype->is_weak ) {
+ # Check that it's a matching type, or a type subsumed by our
+ # bindlevel
+ throw( "Conflicting existing relationship of type "
+ . $existing->type . " at $r, $nr trying to propagate "
+ . $relobj->type . " relationship at @$rel" )
+ unless $existing->type eq $relobj->type
+ || $extype->bindlevel <= $reltype->bindlevel;
+ $skip = 1;
+ }
+ }
+ unless( $skip ) {
# Try to add a new relationship here
try {
my @new = $self->add_relationship( $r, $nr, { type => $relobj->type,
my( $nr, $nrtype ) = @$_;
foreach my $sib ( keys %thislevel ) {
next if $sib eq $r;
+ next if $sib eq $nr; # can happen if linked to $r by tightrel
+ # but linked to a sib of $r by thisrel
+ # e.g. when a rel has been part propagated
my $existing = $self->get_relationship( $sib, $nr );
+ my $skip;
if( $existing ) {
# Check that it's compatible. The existing relationship type
- # should match the looser of the two relationships in play,
- # whether the original relationship being worked on or the
- # relationship between $r and $or.
- if( $nrtype ne $existing->type ) {
- throw( "Conflicting existing relationship at $nr ( -> "
- . $self->get_relationship( $nr, $r )->type . " to $r) "
- . " -- $sib trying to propagate " . $relobj->type
- . " relationship at @$rel" );
+ # should match or be subsumed by the looser of the two
+ # relationships in play, whether the original relationship
+ # being worked on or the relationship between $r and $or.
+ my $extype = $self->type( $existing->type );
+ unless( $extype->is_weak ) {
+ if( $nrtype ne $extype->name
+ && $self->type( $nrtype )->bindlevel <= $extype->bindlevel ) {
+ throw( "Conflicting existing relationship at $nr ( -> "
+ . $self->get_relationship( $nr, $r )->type . " to $r) "
+ . " -- $sib trying to propagate " . $relobj->type
+ . " relationship at @$rel" );
+ }
+ $skip = 1;
}
- } else {
+ }
+ unless( $skip ) {
# Try to add a new relationship here
try {
my @new = $self->add_relationship( $sib, $nr, { type => $nrtype,
return @newly_set;
}
+=head2 propagate_all_relationships
+
+Apply propagation logic retroactively to all relationships in the tradition.
+
+=cut
+
+sub propagate_all_relationships {
+ my $self = shift;
+ my @allrels = sort { $self->_propagate_rel_order( $a, $b ) } $self->relationships;
+ foreach my $rel ( @allrels ) {
+ my $relobj = $self->get_relationship( $rel );
+ if( $self->type( $relobj->type )->is_transitive ) {
+ my @added = $self->propagate_relationship( $rel );
+ }
+ }
+}
+
+# Helper sorting function for retroactive propagation order.
+sub _propagate_rel_order {
+ my( $self, $a, $b ) = @_;
+ my $aobj = $self->get_relationship( $a );
+ my $bobj = $self->get_relationship( $b );
+ my $at = $self->type( $aobj->type ); my $bt = $self->type( $bobj->type );
+ # Apply strong relationships before weak
+ return -1 if $bt->is_weak && !$at->is_weak;
+ return 1 if $at->is_weak && !$bt->is_weak;
+ # Apply more tightly bound relationships first
+ return $at->bindlevel <=> $bt->bindlevel;
+}
+
+
=head2 merge_readings( $kept, $deleted );
Makes a best-effort merge of the relationship links between the given readings, and
=cut
+# TODO Used the 'is_reachable' method; it killed performance. Think about doing away
+# with the equivalence graph in favor of a transitive closure graph (calculated ONCE)
+# on the sequence graph, and test that way.
+
sub test_equivalence {
my( $self, $source, $target ) = @_;
# Try merging the nodes in the equivalence graph; return a true value if
projects / scpubgit/stemmatology.git / blobdiff