From: tla <tla@mit.edu>
Date: Thu, 27 Nov 2014 15:39:06 +0000 (+0100)
Subject: Accept and convert ASCIIfied witness names in Stemweb results. Addresses tla/stemmaweb#46
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c8bc29ebdddf84bdabf3fd3a5e9440e86936f398;p=scpubgit%2Fstemmatology.git

Accept and convert ASCIIfied witness names in Stemweb results. Addresses tla/stemmaweb#46
---

diff --git a/analysis/lib/Text/Tradition/HasStemma.pm b/analysis/lib/Text/Tradition/HasStemma.pm
index 8c508b9..0f20a39 100644
--- a/analysis/lib/Text/Tradition/HasStemma.pm
+++ b/analysis/lib/Text/Tradition/HasStemma.pm
@@ -140,7 +140,7 @@ my $t = Text::Tradition->new(
 
 is( $t->stemma_count, 0, "No stemmas added yet" );
 
-my $answer = from_json( '{"status": 0, "job_id": "4", "algorithm": "RHM", "format": "newick", "start_time": "2013-10-26 10:44:14.050263", "result": "((((((((((((F,U),V),S),T1),T2),A),J),B),L),D),M),C);\n", "end_time": "2013-10-26 10:45:55.398944"}' );
+my $answer = from_json( '{"status": 0, "job_id": "4", "algorithm": "RHM", "format": "newick", "start_time": "2013-10-26 10:44:14.050263", "result": "((((((((((((_A_F,_A_U),_A_V),_A_S),_A_T1),_A_T2),_A_A),_A_J),_A_B),_A_L),_A_D),_A_M),_A_C);\n", "end_time": "2013-10-26 10:45:55.398944"}' );
 my $newst = $t->record_stemweb_result( $answer );
 is( scalar @$newst, 1, "New stemma was returned from record_stemweb_result" );
 is( $newst->[0], $t->stemma(0), "Answer has the right object" );
@@ -149,7 +149,9 @@ is( $t->stemma_count, 1, "Tradition has new stemma" );
 ok( $t->stemma(0)->is_undirected, "New stemma is undirected as it should be" );
 is( $t->stemma(0)->identifier, "RHM 1382784254_0", "Stemma has correct identifier" );
 is( $t->stemma(0)->from_jobid, 4, "New stemma has correct associated job ID" );
-
+foreach my $wit ( $t->stemma(0)->witnesses ) {
+	ok( $t->has_witness( $wit ), "Extant stemma witness $wit exists in tradition" );
+}
 
 =end testing
 
@@ -162,6 +164,8 @@ sub record_stemweb_result {
 	if( $answer->{format} eq 'dot' ) {
 		$self->add_stemma( dot => $answer->{result} );
 	} elsif( $answer->{format} eq 'newick' ) {
+		my $realsig;
+		map { $realsig->{$_->ascii_sigil} = $_->sigil } $self->witnesses;
 		$stemmata = Text::Tradition::Stemma->new_from_newick( $answer->{result} );
 		my $title = sprintf( "%s %d", $answer->{algorithm}, 
 			str2time( $answer->{start_time}, 'UTC' ) );
@@ -170,6 +174,8 @@ sub record_stemweb_result {
 			my $ititle = $title . "_$i"; $i++;
 			$stemma->set_identifier( $ititle );
 			$stemma->_set_from_jobid( $jobid );
+			# Convert back from ASCII sigla
+			$stemma->rename_witnesses( $realsig, 1 );
 			$self->_add_stemma( $stemma );
 		}
 	} else {
diff --git a/analysis/lib/Text/Tradition/Stemma.pm b/analysis/lib/Text/Tradition/Stemma.pm
index b9f84f5..7324067 100644
--- a/analysis/lib/Text/Tradition/Stemma.pm
+++ b/analysis/lib/Text/Tradition/Stemma.pm
@@ -231,6 +231,39 @@ sub new_from_newick {
     return \@stemmata;
 }
 
+=head2 rename_witnesses( \%namehash, $all_extant ) 
+
+Take a hash of old -> new sigil mappings, and change the names of the witnesses.
+
+=cut
+
+sub rename_witnesses {
+	my( $self, $names, $all_extant ) = @_;
+	my $old = $self->graph;
+	my $newdot = $self->editable;
+	foreach my $k ( keys %$names ) {
+		my $v = $names->{$k};
+		$newdot =~ s/\b$k\b/$v/g;
+	}
+	$self->alter_graph( $newdot );
+	if( $all_extant ) {
+		foreach my $v ( values %$names ) {
+			$self->graph->set_vertex_attribute( $v, 'class', 'extant' );
+		}
+		foreach my $v ( $self->graph->vertices ) {
+			unless( $self->graph->has_vertex_attribute( $v, 'class' ) ) {
+				$self->graph->set_vertex_attribute( $v, 'class', 'hypothetical' );
+			}
+		}
+	} else {
+		foreach my $n ( $old->vertices ) {
+			my $v = $names->{$n};
+			my $class = $old->get_vertex_attribute( $n, 'class' );
+			$self->graph->set_vertex_attribute( $v, 'class', $class );
+		}
+	}
+}
+
 =head1 METHODS
 
 =head2 as_dot( \%options )
diff --git a/analysis/t/text_tradition_hasstemma.t b/analysis/t/text_tradition_hasstemma.t
index a86871f..2cfab6b 100644
--- a/analysis/t/text_tradition_hasstemma.t
+++ b/analysis/t/text_tradition_hasstemma.t
@@ -39,7 +39,7 @@ my $t = Text::Tradition->new(
 
 is( $t->stemma_count, 0, "No stemmas added yet" );
 
-my $answer = from_json( '{"status": 0, "job_id": "4", "algorithm": "RHM", "format": "newick", "start_time": "2013-10-26 10:44:14.050263", "result": "((((((((((((F,U),V),S),T1),T2),A),J),B),L),D),M),C);\n", "end_time": "2013-10-26 10:45:55.398944"}' );
+my $answer = from_json( '{"status": 0, "job_id": "4", "algorithm": "RHM", "format": "newick", "start_time": "2013-10-26 10:44:14.050263", "result": "((((((((((((_A_F,_A_U),_A_V),_A_S),_A_T1),_A_T2),_A_A),_A_J),_A_B),_A_L),_A_D),_A_M),_A_C);\n", "end_time": "2013-10-26 10:45:55.398944"}' );
 my $newst = $t->record_stemweb_result( $answer );
 is( scalar @$newst, 1, "New stemma was returned from record_stemweb_result" );
 is( $newst->[0], $t->stemma(0), "Answer has the right object" );
@@ -48,6 +48,9 @@ is( $t->stemma_count, 1, "Tradition has new stemma" );
 ok( $t->stemma(0)->is_undirected, "New stemma is undirected as it should be" );
 is( $t->stemma(0)->identifier, "RHM 1382784254_0", "Stemma has correct identifier" );
 is( $t->stemma(0)->from_jobid, 4, "New stemma has correct associated job ID" );
+foreach my $wit ( $t->stemma(0)->witnesses ) {
+	ok( $t->has_witness( $wit ), "Extant stemma witness $wit exists in tradition" );
+}
 }