{ 'collation' => $self, 'is_end' => 1, 'init' => 1 } ) );
}
+sub register_relationship_type {
+ my $self = shift;
+ my %args = @_ == 1 ? %{$_[0]} : @_;
+ if( $self->relations->has_type( $args{name} ) ) {
+ throw( 'Relationship type ' . $args{name} . ' already registered' );
+ }
+ $self->relations->add_type( %args );
+}
+
### Reading construct/destruct functions
sub add_reading {
# If we are initializing an empty collation, don't assume that we
# have set a tradition.
delete $args{'init'};
- } elsif( $self->tradition->has_language && !exists $args{'language'} ) {
+ } elsif( $self->tradition->can('language') && $self->tradition->has_language
+ && !exists $args{'language'} ) {
$args{'language'} = $self->tradition->language;
}
$reading = Text::Tradition::Collation::Reading->new(
if( $self->sequence->has_edge_attribute( $source, $target, $wit ) ) {
$self->sequence->delete_edge_attribute( $source, $target, $wit );
}
- unless( keys %{$self->sequence->get_edge_attributes( $source, $target )} ) {
+ unless( $self->sequence->has_edge_attributes( $source, $target ) ) {
$self->sequence->delete_edge( $source, $target );
$self->relations->delete_equivalence_edge( $source, $target );
}
my $self = shift;
my( $source, $target, $opts ) = $self->_stringify_args( @_ );
my( @vectors ) = $self->relations->add_relationship( $source, $target, $opts );
- $self->_graphcalc_done(0);
+ foreach my $v ( @vectors ) {
+ next unless $self->get_relationship( $v )->colocated;
+ if( $self->reading( $v->[0] )->has_rank && $self->reading( $v->[1] )->has_rank
+ && $self->reading( $v->[0] )->rank ne $self->reading( $v->[1] )->rank ) {
+ $self->_graphcalc_done(0);
+ $self->_clear_cache;
+ last;
+ }
+ }
return @vectors;
}
# We need only check either the incoming or the outgoing edges; I have
# arbitrarily chosen "incoming". Thus, special-case the start node.
if( $reading eq $self->start ) {
- return map { $_->sigil } $self->tradition->witnesses;
+ return map { $_->sigil } grep { $_->is_collated } $self->tradition->witnesses;
}
my %all_witnesses;
foreach my $e ( $self->sequence->edges_to( $reading ) ) {
$substart{$edge->[1]} = $edge->[0];
}
}
+
+ # If we are asked to, add relationship links
+ if( exists $opts->{show_relations} ) {
+ my $filter = $opts->{show_relations}; # can be 'transposition' or 'all'
+ if( $filter eq 'transposition' ) {
+ $filter =~ qr/^transposition$/;
+ }
+ foreach my $redge ( $self->relationships ) {
+ if( $used{$redge->[0]} && $used{$redge->[1]} ) {
+ if( $filter ne 'all' ) {
+ my $rel = $self->get_relationship( $redge );
+ next unless $rel->type =~ /$filter/;
+ my $variables = {
+ arrowhead => 'none',
+ color => '#FFA14F',
+ constraint => 'false',
+ label => uc( substr( $rel->type, 0, 4 ) ),
+ penwidth => '3',
+ };
+ $dot .= sprintf( "\t\"%s\" -> \"%s\" %s;\n",
+ $redge->[0], $redge->[1], _dot_attr_string( $variables ) );
+ }
+ }
+ }
+ }
+
# Add substitute start and end edges if necessary
foreach my $node ( keys %substart ) {
my $witstr = $self->_path_display_label ( $self->path_witnesses( $substart{$node}, $node ) );
is( scalar $st->collation->relationships, 3, "Reparsed collation has new relationships" );
# Now add a stemma, write to GraphML, and look at the output.
-my $SKIP_STEMMA;
-try {
- $tradition->enable_stemmata;
-} catch {
- $SKIP_STEMMA = 1;
-}
SKIP: {
- skip "Analysis module not present", 3 if $SKIP_STEMMA;
+ skip "Analysis module not present", 3 unless $tradition->can( 'add_stemma' );
my $stemma = $tradition->add_stemma( 'dotfile' => 't/data/florilegium.dot' );
is( ref( $stemma ), 'Text::Tradition::Stemma', "Parsed dotfile into stemma" );
is( $tradition->stemmata, 1, "Tradition now has the stemma" );
like( $graphml, qr/digraph/, "Digraph declaration exists in GraphML" );
}
-# Now add a user, write to GraphML, and look at the output.
-unlike( $graphml, qr/testuser/, "Test user name does not exist in GraphML yet" );
-my $testuser = Text::Tradition::User->new(
- id => 'testuser', password => 'testpass' );
-is( ref( $testuser ), 'Text::Tradition::User', "Created test user object" );
-$testuser->add_tradition( $tradition );
-is( $tradition->user->id, $testuser->id, "Tradition assigned to test user" );
-$graphml = $c->as_graphml;
-like( $graphml, qr/testuser/, "Test user name now exists in GraphML" );
-
=end testing
=cut
};
}
- $graph_attributes{'user'} = sub {
- $self->tradition->user ? $self->tradition->user->id : undef
- };
+ if( $tmeta->has_method('user') ) {
+ $graph_attributes{'user'} = sub {
+ $self->tradition->user ? $self->tradition->user->id : undef
+ };
+ }
foreach my $datum ( sort keys %graph_attributes ) {
$graph_data_keys{$datum} = 'dg'.$gdi++;
return join( "\n", @result );
}
-=head2 alignment_table( $use_refs, $include_witnesses )
+=head2 alignment_table
Return a reference to an alignment table, in a slightly enhanced CollateX
format which looks like this:
... ],
length => TEXTLEN };
-If $use_refs is set to 1, the reading object is returned in the table
-instead of READINGTEXT; if not, the text of the reading is returned.
-
-If $include_witnesses is set to a hashref, only the witnesses whose sigil
-keys have a true hash value will be included.
-
=cut
sub alignment_table {
my( $self ) = @_;
- $self->calculate_ranks() unless $self->_graphcalc_done;
return $self->cached_table if $self->has_cached_table;
# Make sure we can do this
throw( "Need a linear graph in order to make an alignment table" )
unless $self->linear;
- $self->calculate_ranks unless $self->end->has_rank;
-
+ $self->calculate_ranks()
+ unless $self->_graphcalc_done && $self->end->has_rank;
+
my $table = { 'alignment' => [], 'length' => $self->end->rank - 1 };
my @all_pos = ( 1 .. $self->end->rank - 1 );
foreach my $wit ( sort { $a->sigil cmp $b->sigil } $self->tradition->witnesses ) {
# say STDERR "Making witness row(s) for " . $wit->sigil;
my @wit_path = $self->reading_sequence( $self->start, $self->end, $wit->sigil );
my @row = _make_witness_row( \@wit_path, \@all_pos );
- push( @{$table->{'alignment'}},
- { 'witness' => $wit->sigil, 'tokens' => \@row } );
+ my $witobj = { 'witness' => $wit->sigil, 'tokens' => \@row };
+ $witobj->{'identifier'} = $wit->identifier if $wit->identifier;
+ push( @{$table->{'alignment'}}, $witobj );
if( $wit->is_layered ) {
my @wit_ac_path = $self->reading_sequence( $self->start, $self->end,
$wit->sigil.$self->ac_label );
my @ac_row = _make_witness_row( \@wit_ac_path, \@all_pos );
- push( @{$table->{'alignment'}},
- { 'witness' => $wit->sigil.$self->ac_label, 'tokens' => \@ac_row } );
+ my $witacobj = { 'witness' => $wit->sigil.$self->ac_label,
+ 'tokens' => \@ac_row };
+ $witacobj->{'identifier'} = $wit->identifier if $wit->identifier;
+ push( @{$table->{'alignment'}}, $witacobj );
}
}
$self->cached_table( $table );
return @filled_row;
}
+
=head1 NAVIGATION METHODS
=head2 reading_sequence( $first, $last, $sigil, $backup )
is( $c->alignment_table, $table, "Cached table returned upon second call" );
$c->calculate_ranks;
is( $c->alignment_table, $table, "Cached table retained with no rank change" );
-$c->add_relationship( 'n24', 'n23', { 'type' => 'spelling' } );
-isnt( $c->alignment_table, $table, "Alignment table changed after relationship add" );
+$c->add_relationship( 'n13', 'n23', { type => 'repetition' } );
+is( $c->alignment_table, $table, "Alignment table unchanged after non-colo relationship add" );
+$c->add_relationship( 'n24', 'n23', { type => 'spelling' } );
+isnt( $c->alignment_table, $table, "Alignment table changed after colo relationship add" );
=end testing
projects / scpubgit/stemmatology.git / blobdiff