analysis/lib/Text/Tradition/Stemma.pm

   1 package Text::Tradition::Stemma;
   2
   3 use Encode qw( decode_utf8 );
   4 use File::Temp;
   5 use Graph;
   6 use Graph::Reader::Dot;
   7 use IPC::Run qw/ run binary /;
   8 use Text::Tradition::Error;
   9 use Moose;
  10
  11 =head1 NAME
  12
  13 Text::Tradition::Stemma - a representation of a I<stemma codicum> for a Text::Tradition
  14
  15 =head1 SYNOPSIS
  16
  17   use Text::Tradition;
  18   my $t = Text::Tradition->new(
  19     'name' => 'this is a text',
  20     'input' => 'TEI',
  21     'file' => '/path/to/tei_parallel_seg_file.xml' );
  22
  23   my $s = $tradition->add_stemma( dotfile => '/path/to/stemma.dot' );
  24
  25 =head1 DESCRIPTION
  26
  27 Text::Tradition is a library for representation and analysis of collated
  28 texts, particularly medieval ones.  The Stemma is a representation of the
  29 copying relationships between the witnesses in a Tradition, modelled with
  30 a connected rooted directed acyclic graph (CRDAG).
  31
  32 =head1 DOT SYNTAX
  33
  34 The easiest way to define a stemma is to use a special form of the 'dot'
  35 syntax of GraphViz.
  36
  37 Each stemma opens with the line
  38
  39  digraph "Name of Stemma" {
  40
  41 and continues with a list of all manuscript witnesses in the stemma, whether
  42 extant witnesses or missing archetypes or hyparchetypes.  Each of these is
  43 listed by its sigil on its own line, e.g.:
  44
  45   alpha [ class=hypothetical ]
  46   1 [ class=hypothetical,label=* ]
  47   Ms4 [ class=extant ]
  48
  49 Extant witnesses are listed with class=extant; missing or postulated witnesses
  50 are listed with class=hypothetical.  Anonymous hyparchetypes must be given a
  51 unique name or number, but can be represented as anonymous with the addition
  52 of 'label=*' to their lines.  Greek letters or other special characters may be
  53 used as names, but they must always be wrapped in double quotes.
  54
  55 Links between manuscripts are then listed with arrow notation, as below. These
  56 lines show the direction of copying, one step at a time, for the entire stemma.
  57
  58   alpha -> 1
  59   1 -> Ms4
  60
  61 The final line in the definition should be the closing brace:
  62
  63  }
  64
  65 Thus for a set of extant manuscripts A, B, and C, where A and B were copied
  66 from the archetype O and C was copied from B, the definition would be:
  67
  68  digraph "Test stemma 1" {
  69      O [ class=hypothetical]
  70      A [ class=extant ]
  71      B [ class=extant ]
  72      C [ class=extant ]
  73      O -> A
  74      O -> B
  75      B -> C
  76  }
  77
  78 =head1 CONSTRUCTOR
  79
  80 =head2 new
  81
  82 The constructor.  This should generally be called from Text::Tradition, but
  83 if called directly it takes the following options:
  84
  85 =over
  86
  87 =item * dot - A filehandle open to a DOT representation of the stemma graph.
  88
  89 =item * graph - If no DOT specification is given, you can pass a Graph object
  90 instead.  The vertices of the graph should have an attribute 'class' set to
  91 either of the values 'extant' or 'hypothetical'.
  92
  93 =item * is_undirected - If the graph specification (or graph object) is for an
  94 undirected graph (e.g. a phylogenetic tree), this should be set.
  95
  96 =back
  97
  98 =begin testing
  99
 100 use TryCatch;
 101
 102 use_ok( 'Text::Tradition::Stemma' );
 103
 104 # Try to create a bad graph
 105 my $baddotfh;
 106 open( $baddotfh, 't/data/besoin_bad.dot' ) or die "Could not open test dotfile";
 107 try {
 108         my $stemma = Text::Tradition::Stemma->new( dot => $baddotfh );
 109         ok( 0, "Created broken stemma from dotfile with syntax error" );
 110 } catch( Text::Tradition::Error $e ) {
 111         like( $e->message, qr/^Error trying to parse/, "Syntax error in dot threw exception" );
 112 }
 113
 114 # Create a good graph
 115 my $dotfh;
 116 open( $dotfh, 't/data/florilegium.dot' ) or die "Could not open test dotfile";
 117 binmode( $dotfh, ':utf8' );
 118 my $stemma = Text::Tradition::Stemma->new( dot => $dotfh );
 119 is( ref( $stemma ), 'Text::Tradition::Stemma', "Created stemma from good dotfile" );
 120 is( scalar $stemma->witnesses, 13, "Found correct number of extant witnesses" );
 121 is( scalar $stemma->hypotheticals, 8, "Found correct number of extant hypotheticals" );
 122 ok( $stemma->has_identifier, "Stemma identifier was found in dot" );
 123 is( $stemma->identifier, 'Coislinianum lineage', "Correct stemma identifier was found in dot" );
 124 my $found_unicode_sigil;
 125 foreach my $h ( $stemma->hypotheticals ) {
 126         $found_unicode_sigil = 1 if $h eq "\x{3b1}";
 127 }
 128 ok( $found_unicode_sigil, "Found a correctly encoded Unicode sigil" );
 129
 130 # Create an undirected graph
 131 my $undirdotfh;
 132 open( $undirdotfh, 't/data/besoin_undirected.dot' ) or die "Could not open test dotfile";
 133 binmode( $undirdotfh, ':utf8' );
 134 my $udstemma = Text::Tradition::Stemma->new( dot => $undirdotfh );
 135 is( ref( $udstemma ), 'Text::Tradition::Stemma', "Created stemma from undirected dotfile" );
 136 is( scalar $udstemma->witnesses, 13, "Found correct number of extant witnesses" );
 137 is( scalar $udstemma->hypotheticals, 12, "Found correct number of hypotheticals" );
 138 ok( $udstemma->is_undirected, "Stemma was recorded as undirected" );
 139
 140 =end testing
 141
 142 =cut
 143
 144 has collation => (
 145     is => 'ro',
 146     isa => 'Text::Tradition::Collation',
 147     clearer => 'clear_collation', # interim measure to remove refs in DB
 148     weak_ref => 1,
 149     );
 150
 151 has graph => (
 152     is => 'rw',
 153     isa => 'Graph',
 154     predicate => 'has_graph',
 155     );
 156
 157 has identifier => (
 158         is => 'ro',
 159         isa => 'Str',
 160         writer => 'set_identifier',
 161         predicate => 'has_identifier',
 162         );
 163
 164 sub BUILD {
 165     my( $self, $args ) = @_;
 166     # If we have been handed a dotfile, initialize it into a graph.
 167     if( exists $args->{'dot'} ) {
 168         $self->_graph_from_dot( $args->{'dot'} );
 169     }
 170 }
 171
 172 before 'graph' => sub {
 173         my $self = shift;
 174         if( @_ ) {
 175                 # Make sure all unclassed graph nodes are marked extant.
 176                 my $g = $_[0];
 177                 throw( "Cannot set graph to a non-Graph object" )
 178                         unless $g->isa( 'Graph' );
 179                 foreach my $v ( $g->vertices ) {
 180                         unless( $g->has_vertex_attribute( $v, 'class' ) ) {
 181                                 $g->set_vertex_attribute( $v, 'class', 'extant' );
 182                         }
 183                 }
 184         }
 185 };
 186
 187 after 'graph' => sub {
 188         my $self = shift;
 189         return unless @_;
 190         ## HORRIBLE HACK but there is no API access to graph attributes!
 191         my $graph_id = exists $_[0]->[4]->{'name'} ? $_[0]->[4]->{'name'} : '';
 192         if( $graph_id && !( $self->has_identifier && $self->identifier eq $graph_id ) ) {
 193                 $self->set_identifier( $graph_id );
 194         } elsif ( !$graph_id && $self->has_identifier ) {
 195                 $self->set_identifier( 'stemma' );
 196         }
 197 };
 198
 199 sub _graph_from_dot {
 200         my( $self, $dotfh ) = @_;
 201         my $reader = Graph::Reader::Dot->new();
 202         # Redirect STDOUT in order to trap any error messages - syntax errors
 203         # are evidently not fatal.
 204         my $graph;
 205         my $reader_out;
 206         my $reader_err;
 207         {
 208                 local(*STDOUT);
 209                 open( STDOUT, ">", \$reader_out );
 210                 local(*STDERR);
 211                 open( STDERR, ">", \$reader_err );
 212                 $graph = $reader->read_graph( $dotfh );
 213                 close STDOUT;
 214                 close STDERR;
 215         }
 216         if( $reader_out && $reader_out =~ /error/s ) {
 217                 throw( "Error trying to parse dot: $reader_out" );
 218         } elsif( !$graph ) {
 219                 throw( "Failed to create graph from dot" );
 220         }
 221         # Correct for implicit graph -> digraph quirk of reader
 222         if( $reader_err && $reader_err =~ /graph will be treated as digraph/ ) {
 223                 my $udgraph = $graph->undirected_copy;
 224                 foreach my $v ( $graph->vertices ) {
 225                         $udgraph->set_vertex_attributes( $v, $graph->get_vertex_attributes( $v ) );
 226                 }
 227                 $graph = $udgraph;
 228         }
 229         $self->graph( $graph );
 230 }
 231
 232 sub is_undirected {
 233         my( $self ) = @_;
 234         return undef unless $self->has_graph;
 235         return $self->graph->is_undirected;
 236 }
 237
 238 =head1 METHODS
 239
 240 =head2 as_dot( \%options )
 241
 242 Returns a normal dot representation of the stemma layout, suitable for rendering
 243 with GraphViz.  Options include:
 244
 245 =over
 246
 247 =item * graph - A hashref of global graph options.
 248
 249 =item * node - A hashref of global node options.
 250
 251 =item * edge - A hashref of global edge options.
 252
 253 =back
 254
 255 See the GraphViz documentation for the list of available options.
 256
 257 =cut
 258
 259 sub as_dot {
 260     my( $self, $opts ) = @_;
 261
 262         ## See if we are including any a.c. witnesses in this graph.
 263         my $graph = $self->graph;
 264         if( exists $opts->{'layerwits'} ) {
 265                 my $extant = {};
 266                 map { $extant->{$_} = 1 } $self->witnesses;
 267                 $graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
 268         }
 269
 270     # Get default and specified options
 271     my %graphopts = (
 272         # 'ratio' => 1,
 273         'bgcolor' => 'transparent',
 274     );
 275     my %nodeopts = (
 276                 'fontsize' => 11,
 277                 'style' => 'filled',
 278                 'fillcolor' => 'white',
 279                 'color' => 'white',
 280                 'shape' => 'ellipse',   # Shape for the extant nodes
 281         );
 282         my %edgeopts = (
 283                 'arrowhead' => 'none',
 284         );
 285         @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
 286                 if $opts->{'graph'};
 287         @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
 288                 if $opts->{'node'};
 289         @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
 290                 if $opts->{'edge'};
 291
 292         my $gdecl = $graph->is_directed ? 'digraph' : 'graph';
 293         my $gname = $self->has_identifier ? '"' . $self->identifier . '"'
 294                 : 'stemma';
 295         my @dotlines;
 296         push( @dotlines, "$gdecl $gname {" );
 297         ## Print out the global attributes
 298         push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
 299         push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
 300         push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
 301
 302         # Add each of the nodes.
 303     foreach my $n ( $graph->vertices ) {
 304         my %vattr = ( 'id' => $n );  # Set the SVG element ID to the sigil itself
 305         if( $graph->has_vertex_attribute( $n, 'label' ) ) {
 306                 $vattr{'label'} = $graph->get_vertex_attribute( $n, 'label' );
 307         }
 308                 push( @dotlines, _make_dotline( $n, %vattr ) );
 309     }
 310     # Add each of our edges.
 311     foreach my $e ( $graph->edges ) {
 312         my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 313         my $connector = $graph->is_directed ? '->' : '--';
 314         push( @dotlines, "  $from $connector $to;" );
 315     }
 316     push( @dotlines, '}' );
 317
 318     return join( "\n", @dotlines );
 319 }
 320
 321 =head2 alter_graph( $dotstring )
 322
 323 Alters the graph of this stemma according to the definition specified
 324 in $dotstring.
 325
 326 =cut
 327
 328 sub alter_graph {
 329         my( $self, $dotstring ) = @_;
 330         my $dotfh;
 331         open $dotfh, '<', \$dotstring;
 332         binmode $dotfh, ':utf8';
 333         $self->_graph_from_dot( $dotfh );
 334 }
 335
 336 =head2 editable( $opts )
 337
 338 =head2 editable_graph( $graph, $opts )
 339
 340 Returns a version of the graph rendered in our definition format.  The
 341 output separates statements with a newline; set $opts->{'linesep'} to the
 342 empty string or to a space if the result is to be sent via JSON.
 343
 344 If a situational version of the stemma is required, the arguments for
 345 situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.
 346
 347 =cut
 348
 349 sub editable {
 350         my( $self, $opts ) = @_;
 351         my $graph = $self->graph;
 352         if( $self->has_identifier ) {
 353                 $opts->{'name'} = $self->identifier;
 354         }
 355         ## See if we need an editable version of a situational graph.
 356         if( exists $opts->{'layerwits'} || exists $opts->{'extant'} ) {
 357                 my $extant = delete $opts->{'extant'} || {};
 358                 my $layerwits = delete $opts->{'layerwits'} || [];
 359                 $graph = $self->situation_graph( $extant, $layerwits );
 360         }
 361         return editable_graph( $graph, $opts );
 362 }
 363
 364 sub editable_graph {
 365         my( $graph, $opts ) = @_;
 366
 367         # Create the graph
 368         my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
 369         my $gdecl = $graph->is_undirected ? 'graph' : 'digraph';
 370         my $gname = exists $opts->{'name'} ? '"' . $opts->{'name'} . '"'
 371                 : 'stemma';
 372         my @dotlines;
 373         push( @dotlines, "$gdecl $gname {" );
 374         my @real; # A cheap sort
 375     foreach my $n ( sort $graph->vertices ) {
 376         my $c = $graph->get_vertex_attribute( $n, 'class' );
 377         $c = 'extant' unless $c;
 378         if( $c eq 'extant' ) {
 379                 push( @real, $n );
 380         } else {
 381                         push( @dotlines, _make_dotline( $n, 'class' => $c ) );
 382                 }
 383     }
 384         # Now do the real ones
 385         foreach my $n ( @real ) {
 386                 push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
 387         }
 388         foreach my $e ( sort _by_vertex $graph->edges ) {
 389                 my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 390                 my $conn = $graph->is_undirected ? '--' : '->';
 391                 push( @dotlines, "  $from $conn $to;" );
 392         }
 393     push( @dotlines, '}' );
 394     return join( $join, @dotlines );
 395 }
 396
 397 sub _make_dotline {
 398         my( $obj, %attr ) = @_;
 399         my @pairs;
 400         foreach my $k ( keys %attr ) {
 401                 my $v = _dotquote( $attr{$k} );
 402                 push( @pairs, "$k=$v" );
 403         }
 404         return sprintf( "  %s [ %s ];", _dotquote( $obj ), join( ', ', @pairs ) );
 405 }
 406
 407 sub _dotquote {
 408         my( $str ) = @_;
 409         return $str if $str =~ /^[A-Za-z0-9]+$/;
 410         $str =~ s/\"/\\\"/g;
 411         $str = '"' . $str . '"';
 412         return $str;
 413 }
 414
 415 sub _by_vertex {
 416         return $a->[0].$a->[1] cmp $b->[0].$b->[1];
 417 }
 418
 419 =head2 situation_graph( $extant, $layered )
 420
 421 Returns a graph which is the original stemma graph with all witnesses not
 422 in the %$extant hash marked as hypothetical, and witness layers added to
 423 the graph according to the list in @$layered.  A layered (a.c.) witness is
 424 added as a parent of its main version, and additionally shares all other
 425 parents and children with that version.
 426
 427 =cut
 428
 429 sub situation_graph {
 430         my( $self, $extant, $layerwits, $layerlabel ) = @_;
 431
 432         my $graph = $self->graph->copy;
 433         foreach my $vertex ( $graph->vertices ) {
 434                 # Set as extant any vertex that is extant in the stemma AND
 435                 # exists in the $extant hash.
 436                 my $class = 'hypothetical';
 437                 $class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
 438                         $self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
 439                 $graph->set_vertex_attribute( $vertex, 'class', $class );
 440         }
 441
 442         # For each 'layered' witness in the layerwits array, add it to the graph
 443         # as an ancestor of the 'main' witness, and otherwise with the same parent/
 444         # child links as its main analogue.
 445         # TOOD Handle case where B is copied from A but corrected from C
 446         $layerlabel = ' (a.c.)' unless $layerlabel;
 447         foreach my $lw ( @$layerwits ) {
 448                 # Add the layered witness and set it with the same attributes as
 449                 # its 'main' analogue
 450                 throw( "Cannot add a layer to a hypothetical witness $lw" )
 451                         unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
 452                 my $lwac = $lw . $layerlabel;
 453                 $graph->add_vertex( $lwac );
 454                 $graph->set_vertex_attributes( $lwac,
 455                         $graph->get_vertex_attributes( $lw ) );
 456
 457                 # Set it as ancestor to the main witness
 458                 $graph->add_edge( $lwac, $lw );
 459
 460                 # Give it the same ancestors and descendants as the main witness has,
 461                 # bearing in mind that those ancestors and descendants might also just
 462                 # have had a layered witness defined.
 463                 foreach my $v ( $graph->predecessors( $lw ) ) {
 464                         next if $v eq $lwac; # Don't add a loop
 465                         $graph->add_edge( $v, $lwac );
 466                         $graph->add_edge( $v.$layerlabel, $lwac )
 467                                 if $graph->has_vertex( $v.$layerlabel );
 468                 }
 469                 foreach my $v ( $graph->successors( $lw ) ) {
 470                         next if $v eq $lwac; # but this shouldn't occur
 471                         $graph->add_edge( $lwac, $v );
 472                         $graph->add_edge( $lwac, $v.$layerlabel )
 473                                 if $graph->has_vertex( $v.$layerlabel );
 474                 }
 475         }
 476         return $graph;
 477 }
 478
 479 =head2 as_svg
 480
 481 Returns an SVG representation of the graph, calling as_dot first.
 482
 483 =cut
 484
 485 sub as_svg {
 486     my( $self, $opts ) = @_;
 487     my $dot = $self->as_dot( $opts );
 488     my @cmd = ( '-Tsvg' );
 489     unshift( @cmd, $self->is_undirected ? 'neato' : 'dot' );
 490     my $svg;
 491     my $dotfile = File::Temp->new();
 492     binmode $dotfile, ':utf8';
 493     print $dotfile $dot;
 494     close $dotfile;
 495     push( @cmd, $dotfile->filename );
 496     run( \@cmd, ">", binary(), \$svg );
 497     return decode_utf8( $svg );
 498 }
 499
 500 =head2 witnesses
 501
 502 Returns a list of the extant witnesses represented in the stemma.
 503
 504 =cut
 505
 506 sub witnesses {
 507     my $self = shift;
 508     my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
 509         $self->graph->vertices;
 510     return @wits;
 511 }
 512
 513 =head2 hypotheticals
 514
 515 Returns a list of the hypothetical witnesses represented in the stemma.
 516
 517 =cut
 518
 519 sub hypotheticals {
 520     my $self = shift;
 521     my @wits = grep
 522         { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
 523         $self->graph->vertices;
 524     return @wits;
 525 }
 526
 527 =head2 root_graph( $root_vertex )
 528
 529 If the stemma graph is undirected, make it directed with $root_vertex at the root.
 530 If it is directed, re-root it.
 531
 532 =cut
 533
 534 sub root_graph {
 535         my( $self, $rootvertex ) = @_;
 536         my $graph;
 537         my $ident = $self->identifier; # will have to restore this at the end
 538         if( $self->is_undirected ) {
 539                 $graph = $self->graph;
 540         } else {
 541                 # Make an undirected version of this graph.
 542                 $graph = $self->graph->undirected_copy();
 543         }
 544         # First, ensure that the requested root is actually a vertex in the graph.
 545         unless( $graph->has_vertex( $rootvertex ) ) {
 546                 throw( "Cannot orient graph $graph on nonexistent vertex $rootvertex" );
 547         }
 548
 549         # Now make a directed version of the graph.
 550         my $rooted = Graph->new();
 551         $rooted->add_vertex( $rootvertex );
 552         my @next = ( $rootvertex );
 553         while( @next ) {
 554                 my @children;
 555                 foreach my $v ( @next ) {
 556                         # Place its not-placed neighbors (ergo children) in the tree
 557                         # and connect them
 558                         foreach my $n ( grep { !$rooted->has_vertex( $_ ) }
 559                                 $graph->neighbors( $v ) ) {
 560                                 $rooted->add_vertex( $n );
 561                                 $rooted->add_edge( $v, $n );
 562                                 push( @children, $n );
 563                         }
 564                 }
 565                 @next = @children;
 566         }
 567         # Set the vertex classes
 568         map { $rooted->set_vertex_attribute( $_, 'class', 'hypothetical' ) }
 569                 $self->hypotheticals;
 570         map { $rooted->set_vertex_attribute( $_, 'class', 'extant' ) }
 571                 $self->witnesses;
 572         $self->graph( $rooted );
 573         $self->set_identifier( $ident );
 574 }
 575
 576
 577 sub throw {
 578         Text::Tradition::Error->throw(
 579                 'ident' => 'Stemma error',
 580                 'message' => $_[0],
 581                 );
 582 }
 583
 584
 585 no Moose;
 586 __PACKAGE__->meta->make_immutable;
 587
 588 1;
 589
 590 =head1 LICENSE
 591
 592 This package is free software and is provided "as is" without express
 593 or implied warranty.  You can redistribute it and/or modify it under
 594 the same terms as Perl itself.
 595
 596 =head1 AUTHOR
 597
 598 Tara L Andrews E<lt>aurum@cpan.orgE<gt>