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 XML::LibXML;
  12 use Moose;
  13
  14 =head1 NAME
  15
  16 Text::Tradition::Stemma - a representation of a I<stemma codicum> for a Text::Tradition
  17
  18 =head1 SYNOPSIS
  19
  20   use Text::Tradition;
  21   my $t = Text::Tradition->new(
  22     'name' => 'this is a text',
  23     'input' => 'TEI',
  24     'file' => '/path/to/tei_parallel_seg_file.xml' );
  25
  26   my $s = $tradition->add_stemma( dotfile => '/path/to/stemma.dot' );
  27
  28 =head1 DESCRIPTION
  29
  30 Text::Tradition is a library for representation and analysis of collated
  31 texts, particularly medieval ones.  The Collation is the central feature of
  32 a Tradition, where the text, its sequence of readings, and its relationships
  33 between readings are actually kept.
  34
  35 =head1 DOT SYNTAX
  36
  37 The easiest way to define a stemma (which is a directed acyclic graph, denoting
  38 the scholar's hypothesis concerning which text(s) were copied from which other(s))
  39 is to use a special form of the 'dot' syntax of GraphViz.
  40
  41 Each stemma opens with the line
  42
  43  digraph Stemma {
  44
  45 and continues with a list of all manuscript witnesses in the stemma, whether
  46 extant witnesses or missing archetypes or hyparchetypes.  Each of these is
  47 listed by its sigil on its own line, e.g.:
  48
  49   alpha [ class=hypothetical ]
  50   1 [ class=hypothetical,label=* ]
  51   Ms4 [ class=extant ]
  52
  53 Extant witnesses are listed with class=extant; missing or postulated witnesses
  54 are listed with class=hypothetical.  Anonymous hyparchetypes must be given a
  55 unique name or number, but can be represented as anonymous with the addition
  56 of 'label=*' to their lines.  Greek letters or other special characters may be
  57 used as names, but they must always be wrapped in double quotes.
  58
  59 Links between manuscripts are then listed with arrow notation, as below. These
  60 lines show the direction of copying, one step at a time, for the entire stemma.
  61
  62   alpha -> 1
  63   1 -> Ms4
  64
  65 The final line in the definition should be the closing brace:
  66
  67  }
  68
  69 Thus for a set of extant manuscripts A, B, and C, where A and B were copied
  70 from the archetype O and C was copied from B, the definition would be:
  71
  72  digraph Stemma {
  73      O [ class=hypothetical]
  74      A [ class=extant ]
  75      B [ class=extant ]
  76      C [ class=extant ]
  77      O -> A
  78      O -> B
  79      B -> C
  80  }
  81
  82 =head1 CONSTRUCTOR
  83
  84 =head2 new
  85
  86 The constructor.  This should generally be called from Text::Tradition, but
  87 if called directly it takes the following options:
  88
  89 =over
  90
  91 =item * collation - The collation with which the stemma is associated.
  92
  93 =item * dot - A filehandle open to a DOT representation of the stemma graph.
  94
  95 =back
  96
  97 =cut
  98
  99 has collation => (
 100     is => 'ro',
 101     isa => 'Text::Tradition::Collation',
 102     required => 1,
 103     weak_ref => 1,
 104     );
 105
 106 has graph => (
 107     is => 'rw',
 108     isa => 'Graph',
 109     predicate => 'has_graph',
 110     );
 111
 112 sub BUILD {
 113     my( $self, $args ) = @_;
 114     # If we have been handed a dotfile, initialize it into a graph.
 115     if( exists $args->{'dot'} ) {
 116         $self->_graph_from_dot( $args->{'dot'} );
 117     }
 118 }
 119
 120 sub _graph_from_dot {
 121         my( $self, $dotfh ) = @_;
 122         my $reader = Graph::Reader::Dot->new();
 123         my $graph = $reader->read_graph( $dotfh );
 124         if( $graph ) {
 125                 $self->graph( $graph );
 126                 # Go through the nodes and set any non-hypothetical node to extant.
 127                 foreach my $v ( $self->graph->vertices ) {
 128                         $self->graph->set_vertex_attribute( $v, 'class', 'extant' )
 129                                 unless $self->graph->has_vertex_attribute( $v, 'class' );
 130                 }
 131         } else {
 132                 throw( "Failed to parse dot in $dotfh" );
 133         }
 134 }
 135
 136 =head1 METHODS
 137
 138 =head2 as_dot( \%options )
 139
 140 Returns a normal dot representation of the stemma layout, suitable for rendering
 141 with GraphViz.  Options include:
 142
 143 =over
 144
 145 =item * graph - A hashref of global graph options.
 146
 147 =item * node - A hashref of global node options.
 148
 149 =item * edge - A hashref of global edge options.
 150
 151 =back
 152
 153 See the GraphViz documentation for the list of available options.
 154
 155 =cut
 156
 157 sub as_dot {
 158     my( $self, $opts ) = @_;
 159
 160     # Get default and specified options
 161     my %graphopts = (
 162         # 'ratio' => 1,
 163     );
 164     my %nodeopts = (
 165                 'fontsize' => 11,
 166                 'style' => 'filled',
 167                 'fillcolor' => 'white',
 168                 'color' => 'white',
 169                 'shape' => 'ellipse',   # Shape for the extant nodes
 170         );
 171         my %edgeopts = (
 172                 'arrowhead' => 'none',
 173         );
 174         @graphopts{ keys %{$opts->{'graph'}} } = values %{$opts->{'graph'}}
 175                 if $opts->{'graph'};
 176         @nodeopts{ keys %{$opts->{'node'}} } = values %{$opts->{'node'}}
 177                 if $opts->{'node'};
 178         @edgeopts{ keys %{$opts->{'edge'}} } = values %{$opts->{'edge'}}
 179                 if $opts->{'edge'};
 180
 181         my @dotlines;
 182         push( @dotlines, 'digraph stemma {' );
 183         ## Print out the global attributes
 184         push( @dotlines, _make_dotline( 'graph', %graphopts ) ) if keys %graphopts;
 185         push( @dotlines, _make_dotline( 'edge', %edgeopts ) ) if keys %edgeopts;
 186         push( @dotlines, _make_dotline( 'node', %nodeopts ) ) if keys %nodeopts;
 187
 188         # Add each of the nodes.
 189     foreach my $n ( $self->graph->vertices ) {
 190         if( $self->graph->has_vertex_attribute( $n, 'label' ) ) {
 191                 my $ltext = $self->graph->get_vertex_attribute( $n, 'label' );
 192                 push( @dotlines, _make_dotline( $n, 'label' => $ltext ) );
 193         } else {
 194                 # Use the default display settings.
 195             push( @dotlines, "  $n;" );
 196         }
 197     }
 198     # Add each of our edges.
 199     foreach my $e ( $self->graph->edges ) {
 200         my( $from, $to ) = @$e;
 201         push( @dotlines, "  $from -> $to;" );
 202     }
 203     push( @dotlines, '}' );
 204
 205     return join( "\n", @dotlines );
 206 }
 207
 208 =head2 editable( $linesep )
 209
 210 Returns a version of the graph rendered in our definition format.  The
 211 $linesep argument defaults to newline; set it to the empty string or to
 212 a space if the result is to be sent via JSON.
 213
 214 =cut
 215
 216 sub editable {
 217         my $self = shift;
 218         my $join = shift || "\n";
 219         my @dotlines;
 220         push( @dotlines, 'digraph stemma {' );
 221         my @real; # A cheap sort
 222     foreach my $n ( sort $self->graph->vertices ) {
 223         my $c = $self->graph->get_vertex_attribute( $n, 'class' );
 224         $c = 'extant' unless $c;
 225         if( $c eq 'extant' ) {
 226                 push( @real, $n );
 227         } else {
 228                         push( @dotlines, _make_dotline( $n, 'class' => $c ) );
 229                 }
 230     }
 231         # Now do the real ones
 232         foreach my $n ( @real ) {
 233                 push( @dotlines, _make_dotline( $n, 'class' => 'extant' ) );
 234         }
 235         foreach my $e ( sort _by_vertex $self->graph->edges ) {
 236                 my( $from, $to ) = @$e;
 237                 push( @dotlines, "  $from -> $to;" );
 238         }
 239     push( @dotlines, '}' );
 240     return join( $join, @dotlines );
 241 }
 242
 243 sub _make_dotline {
 244         my( $obj, %attr ) = @_;
 245         my @pairs;
 246         foreach my $k ( keys %attr ) {
 247                 my $v = $attr{$k};
 248                 $v =~ s/\"/\\\"/g;
 249                 push( @pairs, "$k=\"$v\"" );
 250         }
 251         return sprintf( "  %s [ %s ];", $obj, join( ', ', @pairs ) );
 252 }
 253
 254 sub _by_vertex {
 255         return $a->[0].$a->[1] cmp $b->[0].$b->[1];
 256 }
 257
 258 =head2 as_svg
 259
 260 Returns an SVG representation of the graph, calling as_dot first.
 261
 262 =cut
 263
 264 sub as_svg {
 265     my( $self, $opts ) = @_;
 266     my $dot = $self->as_dot( $opts );
 267     my @cmd = qw/dot -Tsvg/;
 268     my $svg;
 269     my $dotfile = File::Temp->new();
 270     ## TODO REMOVE
 271     # $dotfile->unlink_on_destroy(0);
 272     binmode $dotfile, ':utf8';
 273     print $dotfile $dot;
 274     push( @cmd, $dotfile->filename );
 275     run( \@cmd, ">", binary(), \$svg );
 276     # HACK: Parse the SVG and change the dimensions.
 277     # Get rid of width and height attributes to allow scaling.
 278     my $parser = XML::LibXML->new();
 279     my $svgdoc = $parser->parse_string( decode_utf8( $svg ) );
 280         $svgdoc->documentElement->removeAttribute('width');
 281         $svgdoc->documentElement->removeAttribute('height');
 282     # Return the result
 283     return decode_utf8( $svgdoc->toString );
 284 }
 285
 286 =head2 witnesses
 287
 288 Returns a list of the extant witnesses represented in the stemma.
 289
 290 =cut
 291
 292 sub witnesses {
 293     my $self = shift;
 294     my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
 295         $self->graph->vertices;
 296     return @wits;
 297 }
 298
 299 sub hypotheticals {
 300     my $self = shift;
 301     my @wits = grep
 302         { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'hypothetical' }
 303         $self->graph->vertices;
 304     return @wits;
 305 }
 306
 307 sub throw {
 308         Text::Tradition::Error->throw(
 309                 'ident' => 'Stemma error',
 310                 'message' => $_[0],
 311                 );
 312 }
 313
 314
 315 no Moose;
 316 __PACKAGE__->meta->make_immutable;
 317
 318 1;
 319
 320 =head1 LICENSE
 321
 322 This package is free software and is provided "as is" without express
 323 or implied warranty.  You can redistribute it and/or modify it under
 324 the same terms as Perl itself.
 325
 326 =head1 AUTHOR
 327
 328 Tara L Andrews E<lt>aurum@cpan.orgE<gt>