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