--- /dev/null
+lib/Text/Tradition/Parser/BaseText.pm
+lib/Text/Tradition/Parser/CollateText.pm
+lib/Text/Tradition/Parser/CTE.pm
+lib/Text/Tradition/Parser/KUL.pm
+lib/Text/Tradition/Analysis.pm
foreach my $edge ( @edges ) {
# Do we need to output this edge?
if( $used{$edge->[0]} && $used{$edge->[1]} ) {
- my $label = $self->path_display_label( $self->path_witnesses( $edge ) );
+ my $label = $self->_path_display_label( $self->path_witnesses( $edge ) );
my $variables = { %edge_attrs, 'label' => $label };
# Account for the rank gap if necessary
if( $self->reading( $edge->[1] )->has_rank
}
# Add substitute start and end edges if necessary
foreach my $node ( keys %substart ) {
- my $witstr = $self->path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
+ my $witstr = $self->_path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
my $variables = { %edge_attrs, 'label' => $witstr };
my $varopts = _dot_attr_string( $variables );
$dot .= "\t\"#SUBSTART#\" -> \"$node\" $varopts;";
}
foreach my $node ( keys %subend ) {
- my $witstr = $self->path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
+ my $witstr = $self->_path_display_label ( $self->reading_witnesses( $self->reading( $node ) ) );
my $variables = { %edge_attrs, 'label' => $witstr };
my $varopts = _dot_attr_string( $variables );
$dot .= "\t\"$node\" -> \"#SUBEND#\" $varopts;";
return( '[ ' . join( ', ', @attrs ) . ' ]' );
}
+=head2 path_witnesses( $edge )
+
+Returns the list of sigils whose witnesses are associated with the given edge.
+The edge can be passed as either an array or an arrayref of ( $source, $target ).
+
+=cut
+
sub path_witnesses {
my( $self, @edge ) = @_;
# If edge is an arrayref, cope.
return @wits;
}
-sub path_display_label {
+sub _path_display_label {
my $self = shift;
my @wits = sort @_;
my $maj = scalar( $self->tradition->witnesses ) * 0.6;
}
# Add the relationship graph to the XML
- $self->relations->as_graphml( $graphml_ns, $root, \%node_hash,
+ $self->relations->_as_graphml( $graphml_ns, $root, \%node_hash,
$node_data_keys{'id'}, \%edge_data_keys );
# Save and return the thing
sub common_predecessor {
my $self = shift;
my( $r1, $r2 ) = $self->_objectify_args( @_ );
- return $self->common_in_path( $r1, $r2, 'predecessors' );
+ return $self->_common_in_path( $r1, $r2, 'predecessors' );
}
sub common_successor {
my $self = shift;
my( $r1, $r2 ) = $self->_objectify_args( @_ );
- return $self->common_in_path( $r1, $r2, 'successors' );
+ return $self->_common_in_path( $r1, $r2, 'successors' );
}
-sub common_in_path {
+sub _common_in_path {
my( $self, $r1, $r2, $dir ) = @_;
my $iter = $r1->rank > $r2->rank ? $r1->rank : $r2->rank;
$iter = $self->end->rank - $iter if $dir eq 'successors';
no Moose;
__PACKAGE__->meta->make_immutable;
-=head1 BUGS / TODO
+=head1 LICENSE
-=over
+This package is free software and is provided "as is" without express
+or implied warranty. You can redistribute it and/or modify it under
+the same terms as Perl itself.
-=item * Get rid of $backup in reading_sequence
+=head1 AUTHOR
-=back
+Tara L Andrews E<lt>aurum@cpan.orgE<gt>
return $self->is_start || $self->is_end || $self->is_lacuna || $self->is_ph;
}
-# Some syntactic sugar
+=head1 Convenience methods
+
+=head2 related_readings
+
+Calls Collation's related_readings with $self as the first argument.
+
+=cut
+
sub related_readings {
my $self = shift;
return $self->collation->related_readings( $self, @_ );
}
+=head2 predecessors
+
+Returns a list of Reading objects that immediately precede $self in the collation.
+
+=cut
+
sub predecessors {
my $self = shift;
my @pred = $self->collation->sequence->predecessors( $self->id );
return map { $self->collation->reading( $_ ) } @pred;
}
+=head2 successors
+
+Returns a list of Reading objects that immediately follow $self in the collation.
+
+=cut
+
sub successors {
my $self = shift;
my @succ = $self->collation->sequence->successors( $self->id );
return map { $self->collation->reading( $_ ) } @succ;
}
+=head2 set_identical( $other_reading)
+
+Backwards compatibility method, to add a transposition relationship
+between $self and $other_reading. Don't use this.
+
+=cut
+
sub set_identical {
my( $self, $other ) = @_;
return $self->collation->add_relationship( $self, $other,
no Moose::Util::TypeConstraints;
+=head1 NAME
+
+Text::Tradition::Collation::Relationship - represents a syntactic or semantic
+relationship between two readings
+
+=head1 DESCRIPTION
+
+Text::Tradition is a library for representation and analysis of collated
+texts, particularly medieval ones. A relationship connects two readings
+within a collation, usually when they appear in the same place in different
+texts.
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+Creates a new relationship. Usually called via $collation->add_relationship.
+Options include:
+
=over 4
=item * type - Can be one of spelling, orthographic, grammatical, meaning, lexical, collated, repetition, transposition. All but the last two are only valid relationships between readings that occur at the same point in the text.
=back
+=head1 ACCESSORS
+
+=head2 type
+
+=head2 displayform
+
+=head2 scope
+
+=head2 non_correctable
+
+=head2 non_independent
+
+See the option descriptions above.
+
=cut
has 'type' => (
);
# A read-only meta-Boolean attribute.
+
+=head2 colocated
+
+Returns true if the relationship type is one that requires that its readings
+occupy the same place in the collation.
+
+=cut
+
sub colocated {
my $self = shift;
return $self->type !~ /^(repetition|transposition)$/;
}
+=head2 nonlocal
+
+Returns true if the relationship scope is anything other than 'local'.
+
+=cut
+
sub nonlocal {
my $self = shift;
return $self->scope ne 'local';
$self->delete_reading( $deleted );
}
-sub as_graphml {
+sub _as_graphml {
my( $self, $graphml_ns, $xmlroot, $node_hash, $nodeid_key, $edge_keys ) = @_;
my $rgraph = $xmlroot->addNewChild( $graphml_ns, 'graph' );
1;
-
\ No newline at end of file
+=head1 LICENSE
+
+This package is free software and is provided "as is" without express
+or implied warranty. You can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Tara L Andrews E<lt>aurum@cpan.orgE<gt>
A basic exception class to throw around, as it were.
-=cut
+=head1 LICENSE
+
+This package is free software and is provided "as is" without express
+or implied warranty. You can redistribute it and/or modify it under
+the same terms as Perl itself.
=head1 AUTHOR
# add them to the witness paths.
foreach my $idx ( 1 .. $#{$alignment_table} ) {
my $row = $alignment_table->[$idx];
- my $nodes = make_nodes( $c, $row, $idx );
+ my $nodes = _make_nodes( $c, $row, $idx );
foreach my $w ( 0 .. $#{$row} ) {
# push the appropriate node onto the appropriate witness path
my $word = $row->[$w];
}
}
-sub make_nodes {
+sub _make_nodes {
my( $collation, $row, $index ) = @_;
my %unique;
my $commonctr = 0; # Holds the number of unique readings + gaps, ex. lacunae.
# transposed reading nodes to be merged into one (producing a
# nonlinear, bidirectional graph) or not (producing a relatively
# linear, unidirectional graph.)
- return $collation->linear ? collate_linearly( @_ )
- : collate_nonlinearly( @_ );
+ return $collation->linear ? _collate_linearly( @_ )
+ : _collate_nonlinearly( @_ );
}
-sub collate_linearly {
+sub _collate_linearly {
my( $collation, $lemma_set, @variant_sets ) = @_;
my @unique;
return $substitutions;
}
-sub collate_nonlinearly {
+sub _collate_nonlinearly {
my( $collation, $lemma_set, @variant_sets ) = @_;
my @unique;
return cmp_str( $node );
}
+=head2 B<cmp_str>
+
+Don't use this. Really.
+
+=cut
+
sub cmp_str {
my( $reading ) = @_;
my $word = $reading->text();
return @repeated;
}
+=head2 B<add_hash_entry>( $hash, $key, $entry )
+
+Very simple utility for adding $entry to the list at $hash->{$key}.
+
+=cut
+
sub add_hash_entry {
my( $hash, $key, $entry ) = @_;
if( exists $hash->{$key} ) {
}
}
-sub is_monotonic {
- my( @readings ) = @_;
- my( $common, $min, $max ) = ( -1, -1, -1 );
- foreach my $rdg ( @readings ) {
-# print STDERR "Checking reading " . $rdg->id . "/" . $rdg->text . " - "
-# . $rdg->position->reference ."\n";
- return 0 if $rdg->position->common < $common;
- if( $rdg->position->common == $common ) {
- return 0 if $rdg->position->min <= $min;
- return 0 if $rdg->position->max <= $max;
- }
- $common = $rdg->position->common;
- $min = $rdg->position->min;
- $max = $rdg->position->max;
- }
- return 1;
-}
-
1;
=head1 BUGS / TODO
use Text::Tradition::StemmaUtil qw/ character_input phylip_pars parse_newick /;
use Moose;
+=head1 NAME
+
+Text::Tradition::Stemma - a representation of a I<stemma codicum> for a Text::Tradition
+
+=head1 SYNOPSIS
+
+ use Text::Tradition;
+ my $t = Text::Tradition->new(
+ 'name' => 'this is a text',
+ 'input' => 'TEI',
+ 'file' => '/path/to/tei_parallel_seg_file.xml' );
+
+ my $s = $tradition->add_stemma( dotfile => '/path/to/stemma.dot' );
+
+=head1 DESCRIPTION
+
+Text::Tradition is a library for representation and analysis of collated
+texts, particularly medieval ones. The Collation is the central feature of
+a Tradition, where the text, its sequence of readings, and its relationships
+between readings are actually kept.
+
+=head1 DOT SYNTAX
+
+The easiest way to define a stemma (which is a directed acyclic graph, denoting
+the scholar's hypothesis concerning which text(s) were copied from which other(s))
+is to use a special form of the 'dot' syntax of GraphViz.
+
+Each stemma opens with the line
+
+ digraph Stemma {
+
+and continues with a list of all manuscript witnesses in the stemma, whether
+extant witnesses or missing archetypes or hyparchetypes. Each of these is
+listed by its sigil on its own line, e.g.:
+
+ alpha [ class=hypothetical ]
+ 1 [ class=hypothetical,label=* ]
+ Ms4 [ class=extant ]
+
+Extant witnesses are listed with class=extant; missing or postulated witnesses
+are listed with class=hypothetical. Anonymous hyparchetypes must be given a
+unique name or number, but can be represented as anonymous with the addition
+of 'label=*' to their lines. Greek letters or other special characters may be
+used as names, but they must always be wrapped in double quotes.
+
+Links between manuscripts are then listed with arrow notation, as below. These
+lines show the direction of copying, one step at a time, for the entire stemma.
+
+ alpha -> 1
+ 1 -> Ms4
+
+The final line in the definition should be the closing brace:
+
+ }
+
+Thus for a set of extant manuscripts A, B, and C, where A and B were copied
+from the archetype O and C was copied from B, the definition would be:
+
+ digraph Stemma {
+ O [ class=hypothetical]
+ A [ class=extant ]
+ B [ class=extant ]
+ C [ class=extant ]
+ O -> A
+ O -> B
+ B -> C
+ }
+
+=head1 CONSTRUCTOR
+
+=head2 new
+
+The constructor. This should generally be called from Text::Tradition, but
+if called directly it takes the following options:
+
+=over
+
+=item * collation - The collation with which the stemma is associated.
+
+=item * dot - A filehandle open to a DOT representation of the stemma graph.
+
+=back
+
+=cut
+
has collation => (
is => 'ro',
isa => 'Text::Tradition::Collation',
my( $self, $args ) = @_;
# If we have been handed a dotfile, initialize it into a graph.
if( exists $args->{'dot'} ) {
- $self->graph_from_dot( $args->{'dot'} );
+ $self->_graph_from_dot( $args->{'dot'} );
}
}
-sub graph_from_dot {
+sub _graph_from_dot {
my( $self, $dotfh ) = @_;
my $reader = Graph::Reader::Dot->new();
my $graph = $reader->read_graph( $dotfh );
}
}
+=head1 METHODS
+
+=head2 as_dot( \%options )
+
+Returns a normal dot representation of the stemma layout, suitable for rendering
+with GraphViz. Options include:
+
+=over
+
+=item * graph - A hashref of global graph options.
+
+=item * node - A hashref of global node options.
+
+=item * edge - A hashref of global edge options.
+
+=back
+
+See the GraphViz documentation for the list of available options.
+
+=cut
+
sub as_dot {
my( $self, $opts ) = @_;
return join( "\n", @dotlines );
}
+=head2 editable
+
+Returns a version of the graph rendered in our definition format.
+
+=cut
-# Another version of dot output meant for graph editing, thus
-# much simpler.
sub editable {
my $self = shift;
my @dotlines;
return $a->[0].$a->[1] cmp $b->[0].$b->[1];
}
-# Render the stemma as SVG.
+=head2 as_svg
+
+Returns an SVG representation of the graph, calling as_dot first.
+
+=cut
+
sub as_svg {
my( $self, $opts ) = @_;
my $dot = $self->as_dot( $opts );
return $svg;
}
+=head2 witnesses
+
+Returns a list of the extant witnesses represented in the stemma.
+
+=cut
+
sub witnesses {
my $self = shift;
my @wits = grep { $self->graph->get_vertex_attribute( $_, 'class' ) eq 'extant' }
return @wits;
}
+=head2 distance_trees( program => $program )
+
+Returns a set of undirected graphs, which are the result of running a distance
+tree calculation program on the collation. Currently the only supported
+program is phylip_pars.
+
+=cut
+
#### Methods for calculating phylogenetic trees ####
before 'distance_trees' => sub {
}
};
+=head2 run_phylip_pars
+
+Runs Phylip Pars on the collation, returning the results in Newick format.
+Used for the distance_trees calculation.
+
+=cut
+
sub run_phylip_pars {
my $self = shift;
my $cdata = character_input( $self->collation->make_alignment_table() );
__PACKAGE__->meta->make_immutable;
1;
+
+=head1 LICENSE
+
+This package is free software and is provided "as is" without express
+or implied warranty. You can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Tara L Andrews E<lt>aurum@cpan.orgE<gt>
@EXPORT_OK = qw/ make_character_matrix character_input phylip_pars
parse_newick newick_to_svg /;
-sub make_character_matrix {
+=head1 NAME
+
+Text::Tradition::StemmaUtil - standalone utilities for distance tree calculations
+
+=head1 DESCRIPTION
+
+This package contains a set of utilities for running phylogenetic analysis on
+text collations.
+
+=head1 SUBROUTINES
+
+=cut
+
+sub _make_character_matrix {
my( $table ) = @_;
# Push the names of the witnesses to initialize the rows of the matrix.
my @matrix = map { [ _normalize_witname( $_->{'witness'} ) ] }
my @pos_readings = map { $_->{'tokens'}->[$token_index] }
@{$table->{'alignment'}};
my @pos_text = map { $_ ? $_->{'t'} : $_ } @pos_readings;
- my @chars = convert_characters( \@pos_text );
+ my @chars = _convert_characters( \@pos_text );
foreach my $idx ( 0 .. $#matrix ) {
push( @{$matrix[$idx]}, $chars[$idx] );
}
return sprintf( "%-10s", $witname );
}
-sub convert_characters {
+sub _convert_characters {
my $row = shift;
# This is a simple algorithm that treats every reading as different.
# Eventually we will want to be able to specify how relationships
return @chars;
}
+=head2 character_input( $alignment_table )
+
+Returns a character matrix string suitable for Phylip programs, which
+corresponds to the given alignment table. See Text::Tradition::Collation
+for a description of the alignment table format.
+
+=cut
+
sub character_input {
my $table = shift;
- my $character_matrix = make_character_matrix( $table );
+ my $character_matrix = _make_character_matrix( $table );
my $input = '';
my $rows = scalar @{$character_matrix};
my $columns = scalar @{$character_matrix->[0]} - 1;
return $input;
}
+=head2 phylip_pars( $character_matrix )
+
+Runs Phylip Pars on the given character matrix. Returns results in Newick format.
+
+=cut
+
sub phylip_pars {
my( $charmatrix ) = @_;
# Set up a temporary directory for all the default Phylip files.
throw( join( '', @error ) );
}
+=head2 parse_newick( $newick_string )
+
+Parses the given Newick tree(s) into one or more undirected Graph objects.
+
+=cut
+
sub parse_newick {
my $newick = shift;
my @trees;
return \@trees;
}
+=head2 newick_to_svg( $newick_string )
+
+Uses the FigTree utility (if installed) to transform the given Newick tree(s)
+into a graph visualization.
+
+=cut
+
sub newick_to_svg {
my $newick = shift;
my $program = File::Which::which( 'figtree' );
);
}
+1;
+
+=head1 LICENSE
+
+This package is free software and is provided "as is" without express
+or implied warranty. You can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=head1 AUTHOR
+
+Tara L Andrews E<lt>aurum@cpan.orgE<gt>
plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
-all_pod_coverage_ok();
+my %mods;
+map { $mods{$_} = 1 } all_modules();
+if( -e 'MANIFEST.SKIP' ) {
+ open( SKIP, 'MANIFEST.SKIP' ) or die "Could not open skip file";
+ while(<SKIP>) {
+ chomp;
+ next unless /^lib/;
+ s/^lib\///;
+ s/\.pm//;
+ s/\//::/g;
+ delete $mods{$_};
+ }
+ close SKIP;
+}
+
+foreach my $mod ( keys %mods ) {
+ pod_coverage_ok( $mod, { also_private => [ qw/ BUILD throw / ] } );
+}
+
+done_testing();
\ No newline at end of file
use Test::More;
use lib 'lib';
use Text::Tradition;
-use Text::Tradition::StemmaUtil qw/ make_character_matrix /;
+use Text::Tradition::StemmaUtil;
use XML::LibXML;
use XML::LibXML::XPathContext;
is( $stemma->graph, '1-2,1-A,2-B,2-C', "Got the correct graph" );
# Test for character matrix creation
-my $m = make_character_matrix( $c->make_alignment_table() );
+my $m = Text::Tradition::StemmaUtil::_make_character_matrix( $c->make_alignment_table() );
## check number of rows
is( scalar @$m, 3, "Found three witnesses in char matrix" );
## check number of columns
projects / scpubgit/stemmatology.git / commitdiff