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         unless( $self->has_identifier ) {
 191                 ## HORRIBLE HACK but there is no API access to graph attributes!
 192                 if( exists $_[0]->[4]->{'name'} ) {
 193                         $self->set_identifier( $_[0]->[4]->{'name'} );
 194                 }
 195         }
 196 };
 197
 198 sub _graph_from_dot {
 199         my( $self, $dotfh ) = @_;
 200         my $reader = Graph::Reader::Dot->new();
 201         # Redirect STDOUT in order to trap any error messages - syntax errors
 202         # are evidently not fatal.
 203         my $graph;
 204         my $reader_out;
 205         my $reader_err;
 206         {
 207                 local(*STDOUT);
 208                 open( STDOUT, ">", \$reader_out );
 209                 local(*STDERR);
 210                 open( STDERR, ">", \$reader_err );
 211                 $graph = $reader->read_graph( $dotfh );
 212                 close STDOUT;
 213                 close STDERR;
 214         }
 215         if( $reader_out && $reader_out =~ /error/s ) {
 216                 throw( "Error trying to parse dot: $reader_out" );
 217         } elsif( !$graph ) {
 218                 throw( "Failed to create graph from dot" );
 219         }
 220         # Correct for implicit graph -> digraph quirk of reader
 221         if( $reader_err && $reader_err =~ /graph will be treated as digraph/ ) {
 222                 my $udgraph = $graph->undirected_copy;
 223                 foreach my $v ( $graph->vertices ) {
 224                         $udgraph->set_vertex_attributes( $v, $graph->get_vertex_attributes( $v ) );
 225                 }
 226                 $graph = $udgraph;
 227         }
 228         $self->graph( $graph );
 229 }
 230
 231 sub is_undirected {
 232         my( $self ) = @_;
 233         return undef unless $self->has_graph;
 234         return $self->graph->is_undirected;
 235 }
 236
 237 =head1 METHODS
 238
 239 =head2 as_dot( \%options )
 240
 241 Returns a normal dot representation of the stemma layout, suitable for rendering
 242 with GraphViz.  Options include:
 243
 244 =over
 245
 246 =item * graph - A hashref of global graph options.
 247
 248 =item * node - A hashref of global node options.
 249
 250 =item * edge - A hashref of global edge options.
 251
 252 =back
 253
 254 See the GraphViz documentation for the list of available options.
 255
 256 =cut
 257
 258 sub as_dot {
 259     my( $self, $opts ) = @_;
 260
 261         ## See if we are including any a.c. witnesses in this graph.
 262         my $graph = $self->graph;
 263         if( exists $opts->{'layerwits'} ) {
 264                 my $extant = {};
 265                 map { $extant->{$_} = 1 } $self->witnesses;
 266                 $graph = $self->situation_graph( $extant, $opts->{'layerwits'} );
 267         }
 268
 269     # Get default and specified options
 270     my %graphopts = (
 271         # 'ratio' => 1,
 272         'bgcolor' => 'transparent',
 273     );
 274     my %nodeopts = (
 275                 'fontsize' => 11,
 276                 'style' => 'filled',
 277                 'fillcolor' => 'white',
 278                 'color' => 'white',
 279                 'shape' => 'ellipse',   # Shape for the extant nodes
 280         );
 281         my %edgeopts = (
 282                 'arrowhead' => 'none',
 283         );
 284         @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
 285                 if $opts->{'graph'};
 286         @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
 287                 if $opts->{'node'};
 288         @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
 289                 if $opts->{'edge'};
 290
 291         my $gdecl = $graph->is_directed ? 'digraph' : 'graph';
 292         my $gname = $self->has_identifier ? '"' . $self->identifier . '"'
 293                 : 'stemma';
 294         my @dotlines;
 295         push( @dotlines, "$gdecl $gname {" );
 296         ## Print out the global attributes
 297         push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
 298         push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
 299         push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
 300
 301         # Add each of the nodes.
 302     foreach my $n ( $graph->vertices ) {
 303         my %vattr = ( 'id' => $n );  # Set the SVG element ID to the sigil itself
 304         if( $graph->has_vertex_attribute( $n, 'label' ) ) {
 305                 $vattr{'label'} = $graph->get_vertex_attribute( $n, 'label' );
 306         }
 307                 push( @dotlines, _make_dotline( $n, %vattr ) );
 308     }
 309     # Add each of our edges.
 310     foreach my $e ( $graph->edges ) {
 311         my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 312         my $connector = $graph->is_directed ? '->' : '--';
 313         push( @dotlines, "  $from $connector $to;" );
 314     }
 315     push( @dotlines, '}' );
 316
 317     return join( "\n", @dotlines );
 318 }
 319
 320 =head2 alter_graph( $dotstring )
 321
 322 Alters the graph of this stemma according to the definition specified
 323 in $dotstring.
 324
 325 =cut
 326
 327 sub alter_graph {
 328         my( $self, $dotstring ) = @_;
 329         my $dotfh;
 330         open $dotfh, '<', \$dotstring;
 331         binmode $dotfh, ':utf8';
 332         $self->_graph_from_dot( $dotfh );
 333 }
 334
 335 =head2 editable( $opts )
 336
 337 =head2 editable_graph( $graph, $opts )
 338
 339 Returns a version of the graph rendered in our definition format.  The
 340 output separates statements with a newline; set $opts->{'linesep'} to the
 341 empty string or to a space if the result is to be sent via JSON.
 342
 343 If a situational version of the stemma is required, the arguments for
 344 situation_graph should be passed via $opts->{'extant'} and $opts->{'layerwits'}.
 345
 346 =cut
 347
 348 sub editable {
 349         my( $self, $opts ) = @_;
 350         my $graph = $self->graph;
 351         if( $self->has_identifier ) {
 352                 $opts->{'name'} = $self->identifier;
 353         }
 354         ## See if we need an editable version of a situational graph.
 355         if( exists $opts->{'layerwits'} || exists $opts->{'extant'} ) {
 356                 my $extant = delete $opts->{'extant'} || {};
 357                 my $layerwits = delete $opts->{'layerwits'} || [];
 358                 $graph = $self->situation_graph( $extant, $layerwits );
 359         }
 360         return editable_graph( $graph, $opts );
 361 }
 362
 363 sub editable_graph {
 364         my( $graph, $opts ) = @_;
 365
 366         # Create the graph
 367         my $join = ( $opts && exists $opts->{'linesep'} ) ? $opts->{'linesep'} : "\n";
 368         my $gdecl = $graph->is_undirected ? 'graph' : 'digraph';
 369         my $gname = exists $opts->{'name'} ? '"' . $opts->{'name'} . '"'
 370                 : 'stemma';
 371         my @dotlines;
 372         push( @dotlines, "$gdecl $gname {" );
 373         my @real; # A cheap sort
 374     foreach my $n ( sort $graph->vertices ) {
 375         my $c = $graph->get_vertex_attribute( $n, 'class' );
 376         $c = 'extant' unless $c;
 377         if( $c eq 'extant' ) {
 378                 push( @real, $n );
 379         } else {
 380                         push( @dotlines, _make_dotline( $n, 'class' => $c ) );
 381                 }
 382     }
 383         # Now do the real ones
 384         foreach my $n ( @real ) {
 385                 push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
 386         }
 387         foreach my $e ( sort _by_vertex $graph->edges ) {
 388                 my( $from, $to ) = map { _dotquote( $_ ) } @$e;
 389                 my $conn = $graph->is_undirected ? '--' : '->';
 390                 push( @dotlines, "  $from $conn $to;" );
 391         }
 392     push( @dotlines, '}' );
 393     return join( $join, @dotlines );
 394 }
 395
 396 sub _make_dotline {
 397         my( $obj, %attr ) = @_;
 398         my @pairs;
 399         foreach my $k ( keys %attr ) {
 400                 my $v = _dotquote( $attr{$k} );
 401                 push( @pairs, "$k=$v" );
 402         }
 403         return sprintf( "  %s [ %s ];", _dotquote( $obj ), join( ', ', @pairs ) );
 404 }
 405
 406 sub _dotquote {
 407         my( $str ) = @_;
 408         return $str if $str =~ /^[A-Za-z0-9]+$/;
 409         $str =~ s/\"/\\\"/g;
 410         $str = '"' . $str . '"';
 411         return $str;
 412 }
 413
 414 sub _by_vertex {
 415         return $a->[0].$a->[1] cmp $b->[0].$b->[1];
 416 }
 417
 418 =head2 situation_graph( $extant, $layered )
 419
 420 Returns a graph which is the original stemma graph with all witnesses not
 421 in the %$extant hash marked as hypothetical, and witness layers added to
 422 the graph according to the list in @$layered.  A layered (a.c.) witness is
 423 added as a parent of its main version, and additionally shares all other
 424 parents and children with that version.
 425
 426 =cut
 427
 428 sub situation_graph {
 429         my( $self, $extant, $layerwits, $layerlabel ) = @_;
 430
 431         my $graph = $self->graph->copy;
 432         foreach my $vertex ( $graph->vertices ) {
 433                 # Set as extant any vertex that is extant in the stemma AND
 434                 # exists in the $extant hash.
 435                 my $class = 'hypothetical';
 436                 $class = 'extant' if exists $extant->{$vertex} && $extant->{$vertex} &&
 437                         $self->graph->get_vertex_attribute( $vertex, 'class' ) ne 'hypothetical';
 438                 $graph->set_vertex_attribute( $vertex, 'class', $class );
 439         }
 440
 441         # For each 'layered' witness in the layerwits array, add it to the graph
 442         # as an ancestor of the 'main' witness, and otherwise with the same parent/
 443         # child links as its main analogue.
 444         # TOOD Handle case where B is copied from A but corrected from C
 445         $layerlabel = ' (a.c.)' unless $layerlabel;
 446         foreach my $lw ( @$layerwits ) {
 447                 # Add the layered witness and set it with the same attributes as
 448                 # its 'main' analogue
 449                 throw( "Cannot add a layer to a hypothetical witness $lw" )
 450                         unless $graph->get_vertex_attribute( $lw, 'class' ) eq 'extant';
 451                 my $lwac = $lw . $layerlabel;
 452                 $graph->add_vertex( $lwac );
 453                 $graph->set_vertex_attributes( $lwac,
 454                         $graph->get_vertex_attributes( $lw ) );
 455
 456                 # Set it as ancestor to the main witness
 457                 $graph->add_edge( $lwac, $lw );
 458
 459                 # Give it the same ancestors and descendants as the main witness has,
 460                 # bearing in mind that those ancestors and descendants might also just
 461                 # have had a layered witness defined.
 462                 foreach my $v ( $graph->predecessors( $lw ) ) {
 463                         next if $v eq $lwac; # Don't add a loop
 464                         $graph->add_edge( $v, $lwac );
 465                         $graph->add_edge( $v.$layerlabel, $lwac )
 466                                 if $graph->has_vertex( $v.$layerlabel );
 467                 }
 468                 foreach my $v ( $graph->successors( $lw ) ) {
 469                         next if $v eq $lwac; # but this shouldn't occur
 470                         $graph->add_edge( $lwac, $v );
 471                         $graph->add_edge( $lwac, $v.$layerlabel )
 472                                 if $graph->has_vertex( $v.$layerlabel );
 473                 }
 474         }
 475         return $graph;
 476 }
 477
 478 =head2 as_svg
 479
 480 Returns an SVG representation of the graph, calling as_dot first.
 481
 482 =cut
 483
 484 sub as_svg {
 485     my( $self, $opts ) = @_;
 486     my $dot = $self->as_dot( $opts );
 487     my @cmd = ( '-Tsvg' );
 488     unshift( @cmd, $self->is_undirected ? 'neato' : 'dot' );
 489     my $svg;
 490     my $dotfile = File::Temp->new();
 491     binmode $dotfile, ':utf8';
 492     print $dotfile $dot;
 493     close $dotfile;
 494     push( @cmd, $dotfile->filename );
 495     run( \@cmd, ">", binary(), \$svg );
 496     return decode_utf8( $svg );
 497 }
 498
 499 =head2 witnesses
 500
 501 Returns a list of the extant witnesses represented in the stemma.
 502
 503 =cut
 504
 505 sub witnesses {
 506     my $self = shift;
 507     my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
 508         $self->graph->vertices;
 509     return @wits;
 510 }
 511
 512 =head2 hypotheticals
 513
 514 Returns a list of the hypothetical witnesses represented in the stemma.
 515
 516 =cut
 517
 518 sub hypotheticals {
 519     my $self = shift;
 520     my @wits = grep
 521         { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
 522         $self->graph->vertices;
 523     return @wits;
 524 }
 525
 526 =head2 root_graph( $root_vertex )
 527
 528 If the stemma graph is undirected, make it directed with $root_vertex at the root.
 529 If it is directed, re-root it.
 530
 531 =cut
 532
 533 sub root_graph {
 534         my( $self, $rootvertex ) = @_;
 535         my $graph;
 536         if( $self->is_undirected ) {
 537                 $graph = $self->graph;
 538         } else {
 539                 # Make an undirected version of this graph.
 540                 $graph = $self->graph->undirected_copy();
 541         }
 542         # First, ensure that the requested root is actually a vertex in the graph.
 543         unless( $graph->has_vertex( $rootvertex ) ) {
 544                 throw( "Cannot orient graph $graph on nonexistent vertex $rootvertex" );
 545         }
 546
 547         # Now make a directed version of the graph.
 548         my $rooted = Graph->new();
 549         $rooted->add_vertex( $rootvertex );
 550         my @next = ( $rootvertex );
 551         while( @next ) {
 552                 my @children;
 553                 foreach my $v ( @next ) {
 554                         # Place its not-placed neighbors (ergo children) in the tree
 555                         # and connect them
 556                         foreach my $n ( grep { !$rooted->has_vertex( $_ ) }
 557                                 $graph->neighbors( $v ) ) {
 558                                 $rooted->add_vertex( $n );
 559                                 $rooted->add_edge( $v, $n );
 560                                 push( @children, $n );
 561                         }
 562                 }
 563                 @next = @children;
 564         }
 565         # Set the vertex classes
 566         map { $rooted->set_vertex_attribute( $_, 'class', 'hypothetical' ) }
 567                 $self->hypotheticals;
 568         map { $rooted->set_vertex_attribute( $_, 'class', 'extant' ) }
 569                 $self->witnesses;
 570         $self->graph( $rooted );
 571 }
 572
 573
 574 sub throw {
 575         Text::Tradition::Error->throw(
 576                 'ident' => 'Stemma error',
 577                 'message' => $_[0],
 578                 );
 579 }
 580
 581
 582 no Moose;
 583 __PACKAGE__->meta->make_immutable;
 584
 585 1;
 586
 587 =head1 LICENSE
 588
 589 This package is free software and is provided "as is" without express
 590 or implied warranty.  You can redistribute it and/or modify it under
 591 the same terms as Perl itself.
 592
 593 =head1 AUTHOR
 594
 595 Tara L Andrews E<lt>aurum@cpan.orgE<gt>