lib/Text/Tradition/Stemma.pm

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