From: Tara L Andrews <tla@mit.edu>
Date: Mon, 3 Jun 2013 10:06:10 +0000 (+0200)
Subject: add method to duplicate a given relationship
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f97ef19e5639265fb59cfefe321493dff0c91904;p=scpubgit%2Fstemmatology.git

add method to duplicate a given relationship
---

diff --git a/base/lib/Text/Tradition/Collation.pm b/base/lib/Text/Tradition/Collation.pm
index 2576646..fcfec83 100644
--- a/base/lib/Text/Tradition/Collation.pm
+++ b/base/lib/Text/Tradition/Collation.pm
@@ -452,6 +452,141 @@ sub _objectify_args {
         unless ref( $second ) eq 'Text::Tradition::Collation::Reading';        
     return( $first, $second, $arg );
 }
+
+=head2 duplicate_reading( $reading, @witlist )
+
+Split the given reading into two, so that the new reading is in the path for
+the witnesses given in @witlist.
+
+=begin testing
+
+use Text::Tradition;
+
+my $st = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/collatecorr.xml' );
+is( ref( $st ), 'Text::Tradition', "Got a tradition from test file" );
+ok( $st->has_witness('Ba96'), "Tradition has the affected witness" );
+
+my $sc = $st->collation;
+my $numr = 17;
+ok( $sc->reading('n131'), "Tradition has the affected reading" );
+is( scalar( $sc->readings ), $numr, "There are $numr readings in the graph" );
+is( $sc->end->rank, 14, "There are fourteen ranks in the graph" );
+
+# Detach the erroneously collated reading
+$sc->duplicate_reading( 'n131', 'Ba96' );
+ok( $sc->reading('n131_0'), "Detached the bad collation with a new reading" );
+is( scalar( $sc->readings ), $numr + 1, "A reading was added to the graph" );
+is( $sc->end->rank, 10, "There are now only ten ranks in the graph" );
+
+# Check that the bad transposition is gone
+is( $sc->get_relationship( 'n130', 'n135' ), undef, "Bad transposition relationship is gone" );
+
+# Fix the collation
+ok( $sc->add_relationship( 'n124', 'n131_0', { type => 'collated', scope => 'local' } ),
+	"Collated the readings correctly" );
+$sc->calculate_ranks();
+$sc->flatten_ranks();
+is( $sc->end->rank, 11, "The ranks shifted appropriately" );
+is( scalar( $sc->readings ), $numr - 3, "Now we are collated correctly" );
+
+=end testing
+
+=cut
+
+sub duplicate_reading {
+	my( $self, $r, @wits ) = @_;
+	# Add the new reading, duplicating $r.
+	unless( ref( $r ) eq 'Text::Tradition::Collation::Reading' ) {
+		$r = $self->reading( $r );
+	}
+	throw( "Cannot duplicate a meta-reading" )
+		if $r->is_meta;
+	
+	# Get all the reading attributes and duplicate them.	
+	my $rmeta = Text::Tradition::Collation::Reading->meta;
+	my %args;
+    foreach my $attr( $rmeta->get_all_attributes ) {
+		next if $attr->name =~ /^_/;
+		my $acc = $attr->get_read_method;
+		if( !$acc && $attr->has_applied_traits ) {
+			my $tr = $attr->applied_traits;
+			if( $tr->[0] =~ /::(Array|Hash)$/ ) {
+				my $which = $1;
+				my %methods = reverse %{$attr->handles};
+				$acc = $methods{elements};
+				$args{$attr->name} = $which eq 'Array' 
+					? [ $r->$acc ] : { $r->$acc };
+			} 
+		} else {
+			$args{$attr->name} = $r->$acc if $acc;
+		}
+	}
+	# By definition the new reading will no longer be common.
+	$args{is_common} = 0;
+	# The new reading also needs its own ID.
+	$args{id} = $self->_generate_dup_id( $r->id );
+
+	# Try to make the new reading.
+	my $newr = $self->add_reading( \%args );
+	# The old reading is also no longer common.
+	$r->is_common( 0 );
+	
+	# For each of the witnesses, dissociate from the old reading and
+	# associate with the new.
+	foreach my $wit ( @wits ) {
+		my $prior = $self->prior_reading( $r, $wit );
+		my $next = $self->next_reading( $r, $wit );
+		$self->del_path( $prior, $r, $wit );
+		$self->add_path( $prior, $newr, $wit );
+		$self->del_path( $r, $next, $wit );
+		$self->add_path( $newr, $next, $wit );
+	}
+	
+	# Hash the reading ranks and find the closest common successor to our
+	# two readings
+	my %rrk;
+	my $succ;
+	if( $self->end->has_rank ) {
+		$succ = $self->common_successor( $r, $newr );
+		foreach my $rdg ( $self->readings ) {
+			$rrk{$rdg->id} = $rdg->rank;
+		}
+	}
+
+	# Rebuild the equivalence graph and calculate the new ranks	
+	$self->relations->rebuild_equivalence();
+	$self->calculate_ranks();
+	
+	# Check for invalid non-colocated relationships among changed-rank readings
+	# from where the ranks start changing up to $succ
+	if( $self->end->has_rank ) {
+		my $lastrank = $succ->rank;
+		foreach my $rdg ( $self->readings ) {
+			next if $rdg->rank > $lastrank;
+			next if $rdg->rank == $rrk{$rdg->id};
+			my @noncolo = $rdg->related_readings( sub { !$_[0]->colocated } );
+			next unless @noncolo;
+			foreach my $nc ( @noncolo ) {
+				$self->relations->verify_or_delete( $rdg, $nc );
+			}
+		}
+	}	
+}
+
+sub _generate_dup_id {
+	my( $self, $rid ) = @_;
+	my $newid;
+	my $i = 0;
+	while( !$newid ) {
+		$newid = $rid."_$i";
+		if( $self->has_reading( $newid ) ) {
+			$newid = '';
+			$i++;
+		}
+	}
+	return $newid;
+}
+
 ### Path logic
 
 sub add_path {
@@ -481,7 +616,7 @@ sub del_path {
 		@args = @_;
 	}
 
-	# We only need the IDs for adding paths to the graph, not the reading
+	# We only need the IDs for removing paths from the graph, not the reading
 	# objects themselves.
     my( $source, $target, $wit ) = $self->_stringify_args( @args );
 
@@ -1020,6 +1155,8 @@ sub as_graphml {
     my %graph_attributes = ( 'version' => 'string' );
 	# Graph attributes include those of Tradition and those of Collation.
 	my %gattr_from;
+	# TODO Use meta introspection method from duplicate_reading to do this
+	# instead of naming custom keys.
 	my $tmeta = $self->tradition->meta;
 	my $cmeta = $self->meta;
 	map { $gattr_from{$_->name} = 'Tradition' } $tmeta->get_all_attributes;
diff --git a/base/lib/Text/Tradition/Collation/RelationshipStore.pm b/base/lib/Text/Tradition/Collation/RelationshipStore.pm
index 2b53d87..3226fd2 100644
--- a/base/lib/Text/Tradition/Collation/RelationshipStore.pm
+++ b/base/lib/Text/Tradition/Collation/RelationshipStore.pm
@@ -947,6 +947,26 @@ sub _restore_weak {
 	}
 }
 
+=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
@@ -1267,6 +1287,10 @@ the graph would still be valid.
 
 =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
diff --git a/base/t/text_tradition_collation.t b/base/t/text_tradition_collation.t
index 6f5041c..ec281e5 100644
--- a/base/t/text_tradition_collation.t
+++ b/base/t/text_tradition_collation.t
@@ -53,6 +53,40 @@ is( $c->reading('n21p0')->text, 'unto', "Reading n21p0 merged correctly" );
 # =begin testing
 {
 use Text::Tradition;
+
+my $st = Text::Tradition->new( 'input' => 'Self', 'file' => 't/data/collatecorr.xml' );
+is( ref( $st ), 'Text::Tradition', "Got a tradition from test file" );
+ok( $st->has_witness('Ba96'), "Tradition has the affected witness" );
+
+my $sc = $st->collation;
+my $numr = 17;
+ok( $sc->reading('n131'), "Tradition has the affected reading" );
+is( scalar( $sc->readings ), $numr, "There are $numr readings in the graph" );
+is( $sc->end->rank, 14, "There are fourteen ranks in the graph" );
+
+# Detach the erroneously collated reading
+$sc->duplicate_reading( 'n131', 'Ba96' );
+ok( $sc->reading('n131_0'), "Detached the bad collation with a new reading" );
+is( scalar( $sc->readings ), $numr + 1, "A reading was added to the graph" );
+is( $sc->end->rank, 10, "There are now only ten ranks in the graph" );
+
+# Check that the bad transposition is gone
+is( $sc->get_relationship( 'n130', 'n135' ), undef, "Bad transposition relationship is gone" );
+
+# Fix the collation
+ok( $sc->add_relationship( 'n124', 'n131_0', { type => 'collated', scope => 'local' } ),
+	"Collated the readings correctly" );
+$sc->calculate_ranks();
+$sc->flatten_ranks();
+is( $sc->end->rank, 11, "The ranks shifted appropriately" );
+is( scalar( $sc->readings ), $numr - 3, "Now we are collated correctly" );
+}
+
+
+
+# =begin testing
+{
+use Text::Tradition;
 use TryCatch;
 
 my $READINGS = 311;