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 (file)
--- 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 (file)
--- 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 (file)
--- 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" );
+}
 }