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' } );
is( scalar $c5->relationships, $numrel+4,
"Adding non-colo relationship only propagated on non-colos" );
-# TODO test that attempts to cross boundaries on bindlevel-equal relationships fail.
+# 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" );
+}
-# TODO test that weak relationships don't interfere
+# 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" );
+}
-# TODO test that strong non-transitive relationships don't interfere
+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
=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