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