File Coverage

blib/lib/Bio/Phylo/Matrices/DatumRole.pm
Criterion Covered Total %
statement 121 409 29.5
branch 28 154 18.1
condition 3 80 3.7
subroutine 23 62 37.1
pod 21 48 43.7
total 196 753 26.0


line stmt bran cond sub pod time code
1             package Bio::Phylo::Matrices::DatumRole;
2 16     16   87 use strict;
  16         34  
  16         406  
3 16     16   574 use Bio::Phylo::Util::MOP;
  16         33  
  16         117  
4 16     16   74 use base qw'Bio::Phylo::Matrices::TypeSafeData Bio::Phylo::Taxa::TaxonLinker';
  16         29  
  16         5434  
5 16     16   837 use Bio::Phylo::Util::OptionalInterface 'Bio::Seq';
  16         34  
  16         105  
6 16     16   104 use Bio::Phylo::Util::Exceptions 'throw';
  16         29  
  16         782  
7 16     16   92 use Bio::Phylo::Util::CONSTANT qw':objecttypes /looks_like/';
  16         29  
  16         3953  
8 16     16   107 use Bio::Phylo::NeXML::Writable;
  16         40  
  16         98  
9 16     16   84 use Bio::Phylo::Factory;
  16         31  
  16         89  
10             my $LOADED_WRAPPERS = 0;
11             {
12             my $fac = Bio::Phylo::Factory->new;
13             my $logger = __PACKAGE__->get_logger;
14             my $TYPE_CONSTANT = _DATUM_;
15             my $CONTAINER_CONSTANT = _MATRIX_;
16             #{
17             #my @fields = \( my ( %weight, %position, %annotations ) );
18             #}
19              
20             =head1 NAME
21              
22             Bio::Phylo::Matrices::DatumRole - Extra behaviours for a character state sequence
23              
24             =head1 SYNOPSIS
25              
26             use Bio::Phylo::Factory;
27             my $fac = Bio::Phylo::Factory->new;
28              
29             # instantiating a datum object...
30             my $datum = $fac->create_datum(
31             -name => 'Tooth comb size,
32             -type => 'STANDARD',
33             -desc => 'number of teeth in lower jaw comb',
34             -pos => 1,
35             -weight => 2,
36             -char => [ 6 ],
37             );
38              
39             # ...and linking it to a taxon object
40             my $taxon = $fac->create_taxon(
41             -name => 'Lemur_catta'
42             );
43             $datum->set_taxon( $taxon );
44              
45             # instantiating a matrix...
46             my $matrix = $fac->create_matrix;
47              
48             # ...and insert datum in matrix
49             $matrix->insert($datum);
50              
51             =head1 DESCRIPTION
52              
53             The datum object models a single observation or a sequence of observations,
54             which can be linked to a taxon object.
55              
56             =head1 METHODS
57              
58             =head2 CONSTRUCTOR
59              
60             =over
61              
62             =item new()
63              
64             Datum object constructor.
65              
66             Type : Constructor
67             Title : new
68             Usage : my $datum = Bio::Phylo::Matrices::Datum->new;
69             Function: Instantiates a Bio::Phylo::Matrices::Datum
70             object.
71             Returns : A Bio::Phylo::Matrices::Datum object.
72             Args : None required. Optional:
73             -taxon => $taxon,
74             -weight => 0.234,
75             -type => DNA,
76             -pos => 2,
77              
78             =cut
79              
80             sub new : Constructor {
81              
82             # could be child class
83 724     724 1 1291 my $class = shift;
84              
85             # notify user
86 724         2912 $logger->info("constructor called for '$class'");
87 724 100       1627 if ( not $LOADED_WRAPPERS ) {
88 14 0 0 0 0 183 eval do { local $/; };
  14 0 0 0 0 66  
  14 0 0 0 0 13675  
  0 0 0 0 0 0  
  0 0 0 0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0 0   0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0     0 0 0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
89 14 50       175 die $@ if $@;
90 14         210 $LOADED_WRAPPERS++;
91             }
92              
93             # go up inheritance tree, eventually get an ID
94 724         2949 my $self = $class->SUPER::new(
95             @_,
96             '-listener' => \&_update_characters,
97             );
98 724         2454 return $self;
99 16     16   99 }
  16         32  
  16         92  
100              
101             =item new_from_bioperl()
102              
103             Datum constructor from Bio::Seq argument.
104              
105             Type : Constructor
106             Title : new_from_bioperl
107             Usage : my $datum =
108             Bio::Phylo::Matrices::Datum->new_from_bioperl($seq);
109             Function: Instantiates a
110             Bio::Phylo::Matrices::Datum object.
111             Returns : A Bio::Phylo::Matrices::Datum object.
112             Args : A Bio::Seq (or similar) object
113              
114             =cut
115              
116             sub new_from_bioperl {
117 0     0 1 0 my ( $class, $seq, @args ) = @_;
118              
119             # want $seq type-check here? Allowable: is-a Bio::PrimarySeq,
120             # Bio::LocatableSeq /maj
121 0   0     0 my $type = $seq->alphabet || $seq->_guess_alphabet || 'dna';
122 0         0 my $self = $class->new( '-type' => $type, @args );
123              
124             # copy seq string
125 0         0 my $seqstring = $seq->seq;
126 0 0 0     0 if ( $seqstring and $seqstring =~ /\S/ ) {
127 0         0 eval { $self->set_char($seqstring) };
  0         0  
128 0 0 0     0 if (
129             $@
130             and looks_like_instance(
131             $@, 'Bio::Phylo::Util::Exceptions::InvalidData'
132             )
133             )
134             {
135 0         0 $logger->error(
136             "\nAn exception of type Bio::Phylo::Util::Exceptions::InvalidData was caught\n\n"
137             . $@->description
138             . "\n\nThe BioPerl sequence object contains invalid data ($seqstring)\n"
139             . "I cannot store this string, I will continue instantiating an empty object.\n"
140             . "---------------------------------- STACK ----------------------------------\n"
141             . $@->trace->as_string
142             . "\n--------------------------------------------------------------------------"
143             );
144             }
145             }
146              
147             # copy name
148 0         0 my $name = $seq->display_id;
149 0 0       0 $self->set_name($name) if defined $name;
150              
151             # copy desc
152 0         0 my $desc = $seq->desc;
153 0 0       0 $self->set_desc($desc) if defined $desc;
154              
155             # only Bio::LocatableSeq objs have these fields...
156 0         0 for my $field (qw(start end strand)) {
157 0 0       0 $self->$field( $seq->$field ) if $seq->can($field);
158             }
159 0         0 return $self;
160             }
161              
162             =back
163              
164             =head2 MUTATORS
165              
166             =over
167              
168             =item set_char()
169              
170             Sets character state(s)
171              
172             Type : Mutator
173             Title : set_char
174             Usage : $datum->set_char($char);
175             Function: Assigns a datum's character value.
176             Returns : Modified object.
177             Args : The $char argument is checked against
178             the allowed ranges for the various
179             character types: IUPAC nucleotide (for
180             types of DNA|RNA|NUCLEOTIDE), IUPAC
181             single letter amino acid codes (for type
182             PROTEIN), integers (STANDARD) or any of perl's
183             decimal formats (CONTINUOUS). The $char can be:
184             * a single character;
185             * a string of characters;
186             * an array reference of characters;
187             * an array of characters;
188             Comments: Note that on assigning characters to a datum,
189             previously set annotations are removed.
190              
191             =cut
192              
193             sub set_char {
194 713     713 1 1099 my $self = shift;
195 713         1909 my $name = $self->get_internal_name;
196 713 100       2166 my $length = ref $_[0] ? join( '', @{ $_[0] } ) : join( '', @_ );
  69         186  
197 713         3763 $logger->info("setting $name $length chars '@_'");
198 713         1177 my @data;
199 713         1360 for my $arg (@_) {
200 713 100       1732 if ( looks_like_instance( $arg, 'ARRAY' ) ) {
201 69         115 push @data, @{$arg};
  69         222  
202             }
203             else {
204 644         865 push @data, @{ $self->get_type_object->split($arg) };
  644         1438  
205             }
206             }
207 713         2025 my $missing = $self->get_missing;
208 713   50     1947 my $position = $self->get_position || 1;
209 713         2025 for ( 1 .. $position - 1 ) {
210 0         0 unshift @data, $missing;
211             }
212 713         915 my @char = @{ $self->get_entities }; # store old data for rollback
  713         1599  
213 713         1184 eval {
214 713         1924 $self->clear;
215 713         2187 $self->insert(@data);
216             };
217 713 100       1540 if ($@) {
218 7         24 $self->clear;
219 7         11 eval { $self->insert(@char) };
  7         57  
220 7         19 undef($@);
221 7         24 throw 'InvalidData' =>
222             sprintf( 'Invalid data for row %s (type %s: %s)',
223             $self->get_internal_name, $self->get_type, join( ' ', @data ) );
224             }
225 706         2393 $self->set_annotations;
226 706         5350 return $self;
227             }
228              
229             =back
230              
231             =head2 ACCESSORS
232              
233             =over
234              
235             =item get_matrix()
236              
237             Gets the matrix (if any) this datum belongs to
238              
239             Type : Accessor
240             Title : get_matrix
241             Usage : my $matrix = $datum->get_matrix;
242             Function: Retrieves the matrix the datum belongs to
243             Returns : Bio::Phylo::Matrices::Matrix
244             Args : NONE
245              
246             =cut
247              
248 133     133 1 373 sub get_matrix { shift->_get_container }
249              
250             =item get_char()
251              
252             Gets characters.
253              
254             Type : Accessor
255             Title : get_char
256             Usage : my $char = $datum->get_char;
257             Function: Retrieves a datum's character value.
258             Returns : In scalar context, returns a single
259             character, or a string of characters
260             (e.g. a DNA sequence, or a space
261             delimited series of continuous characters).
262             In list context, returns a list of characters
263             (of zero or more characters).
264             Args : NONE
265              
266             =cut
267              
268             sub get_char {
269 1462     1462 1 3457 my $self = shift;
270 1462         1912 my @data = @{ $self->get_entities };
  1462         3302  
271 1462 100       3250 if (@data) {
272 715 100       15549 return wantarray ? @data : $self->get_type_object->join( \@data );
273             }
274             else {
275 747 50       2326 return wantarray ? () : '';
276             }
277             }
278            
279             =item get_unaligned_char()
280              
281             Gets unaligned characters, i.e. without gap or missing symbols
282              
283             Type : Accessor
284             Title : get_unaligned_char
285             Usage : my $char = $datum->get_unaligned_char;
286             Function: Retrieves a datum's unaligned character sequence
287             Returns : In scalar context, returns a single
288             character, or a string of characters
289             (e.g. a DNA sequence, or a space
290             delimited series of continuous characters).
291             In list context, returns a list of characters
292             (of zero or more characters).
293             Args : NONE
294              
295             =cut
296            
297             sub get_unaligned_char {
298 0     0 1 0 my $self = shift;
299 0         0 my $gap = $self->get_gap;
300 0         0 my $missing = $self->get_missing;
301 0         0 my @char = $self->get_char;
302 0 0       0 my @data = grep { $_ ne $gap && $_ ne $missing } @char;
  0         0  
303 0 0       0 if (@data) {
304 0 0       0 return wantarray ? @data : $self->get_type_object->join( \@data );
305             }
306             else {
307 0 0       0 return wantarray ? () : '';
308             }
309             }
310              
311             =item get_length()
312              
313             Gets invocant number of characters.
314              
315             Type : Accessor
316             Title : get_length
317             Usage : my $length = $datum->get_length;
318             Function: Retrieves a datum's length.
319             Returns : a SCALAR integer.
320             Args : NONE
321              
322             =cut
323              
324             sub get_length {
325 623     623 1 797 my $self = shift;
326 623 100       1478 if ( my $matrix = $self->_get_container ) {
327 39         130 return $matrix->get_nchar;
328             }
329             else {
330 584   50     742 return scalar( @{ $self->get_entities } ) + ( $self->get_position || 1 ) - 1;
  584         1288  
331             }
332             }
333              
334             =item get_by_index()
335              
336             Gets state at argument index.
337              
338             Type : Accessor
339             Title : get_by_index
340             Usage : my $val = $datum->get_by_index($i);
341             Function: Retrieves state at index $i.
342             Returns : a character state.
343             Args : INT
344              
345             =cut
346              
347             sub get_by_index {
348 50     50 1 65 my ( $self, $index ) = @_;
349 50         109 $logger->debug($index);
350 50   50     91 my $offset = ( $self->get_position || 1 ) - 1;
351 50 50       87 return $self->get_type_object->get_missing if $offset > $index;
352 50         108 my $val = $self->SUPER::get_by_index( $index - $offset );
353 50 50       113 return defined $val ? $val : $self->get_type_object->get_missing;
354             }
355              
356             =item get_index_of()
357              
358             Returns the index of the first occurrence of the
359             state observation in the datum or undef if the datum
360             doesn't contain the argument
361              
362             Type : Generic query
363             Title : get_index_of
364             Usage : my $i = $datum->get_index_of($state)
365             Function: Returns the index of the first occurrence of the
366             state observation in the datum or undef if the datum
367             doesn't contain the argument
368             Returns : An index or undef
369             Args : A contained object
370              
371             =cut
372              
373             sub get_index_of {
374 0     0 1 0 my ( $self, $obj ) = @_;
375 0         0 my $is_numerical =
376             $self->get_type =~ m/^(Continuous|Standard|Restriction)$/;
377 0         0 my $i = 0;
378 0         0 for my $ent ( @{ $self->get_entities } ) {
  0         0  
379 0 0       0 if ($is_numerical) {
380 0 0       0 return $i if $obj == $ent;
381             }
382             else {
383 0 0       0 return $i if $obj eq $ent;
384             }
385 0         0 $i++;
386             }
387 0         0 return;
388             }
389              
390             =back
391              
392             =head2 TESTS
393              
394             =over
395              
396             =item can_contain()
397              
398             Tests if invocant can contain argument.
399              
400             Type : Test
401             Title : can_contain
402             Usage : &do_something if $datum->can_contain( @args );
403             Function: Tests if $datum can contain @args
404             Returns : BOOLEAN
405             Args : One or more arguments as can be provided to set_char
406              
407             =cut
408              
409             sub can_contain {
410 719     719 1 1091 my $self = shift;
411 719         10099 my @data = @_;
412 719 50       1568 if ( my $obj = $self->get_type_object ) {
413 719 50       4115 if ( $obj->isa('Bio::Phylo::Matrices::Datatype::Mixed') ) {
414 0         0 my @split;
415 0         0 for my $datum (@data) {
416 0 0       0 if ( looks_like_implementor( $datum, 'get_char' ) ) {
    0          
417 0         0 my @tmp = $datum->get_char();
418 0         0 my $i = $datum->get_position() - 1;
419 0         0 for (@tmp) {
420 0         0 $split[ $i++ ] = $_;
421             }
422             }
423             elsif ( looks_like_instance( $datum, 'ARRAY' ) ) {
424 0         0 push @split, @{$datum};
  0         0  
425             }
426             else {
427 0         0 my $subtype = $obj->get_type_for_site( scalar(@split) );
428 0         0 push @split, @{ $subtype->split($datum) };
  0         0  
429             }
430             }
431              
432             #return 1;
433 0         0 for my $i ( 1 .. scalar(@split) ) {
434 0         0 my $subtype = $obj->get_type_for_site( $i - 1 );
435 0 0       0 next if $subtype->is_valid( $split[ $i - 1 ] );
436 0         0 throw 'InvalidData' => sprintf(
437             'Invalid char %s at pos %s for type %s',
438             $split[ $i - 1 ],
439             $i, $subtype->get_type,
440             );
441             }
442 0         0 return 1;
443             }
444             else {
445 719         2711 return $obj->is_valid(@data);
446             }
447             }
448             else {
449 0         0 throw 'API' => "No associated type object found,\n"
450             . "this is a bug - please report - thanks";
451             }
452             }
453              
454             =back
455              
456             =head2 CALCULATIONS
457              
458             =over
459              
460             =item calc_state_counts()
461              
462             Calculates occurrences of states.
463              
464             Type : Calculation
465             Title : calc_state_counts
466             Usage : my %counts = %{ $datum->calc_state_counts };
467             Function: Calculates occurrences of states.
468             Returns : Hashref: keys are states, values are counts
469             Args : Optional - one or more states to focus on
470              
471             =cut
472              
473             sub calc_state_counts {
474 23     23 1 36 my $self = shift;
475              
476             # maybe there should be an option to bin continuous values
477             # in X categories, and return the frequencies of those? Anyway,
478             # Hennig86 seems to want continuous values to be counted as well,
479             # so not throwing an exception here.
480             #if ( $self->get_type =~ /^continuous$/i ) {
481             # throw 'BadArgs' => 'Matrix holds continuous values';
482             #}
483 23         30 my %counts;
484 23 50       45 if (@_) {
485 0         0 my %focus = map { $_ => 1 } @_;
  0         0  
486 0         0 my @char = $self->get_char;
487 0         0 for my $c (@char) {
488 0 0       0 if ( exists $focus{$c} ) {
489 0 0       0 if ( not exists $counts{$c} ) {
490 0         0 $counts{$c} = 1;
491             }
492             else {
493 0         0 $counts{$c}++;
494             }
495             }
496             }
497             }
498             else {
499 23         54 my @char = $self->get_char;
500 23         42 for my $c (@char) {
501 101 100       159 if ( not exists $counts{$c} ) {
502 80         141 $counts{$c} = 1;
503             }
504             else {
505 21         35 $counts{$c}++;
506             }
507             }
508             }
509 23         51 return \%counts;
510             }
511              
512             =item calc_distance()
513              
514             Calculates the distance between the invocant and argument
515              
516             Type : Calculation
517             Title : calc_distance
518             Usage : my $dist = $datum1->calc_distance($datum2);
519             Function: Calculates pairwise distance
520             Returns : A number, the distance per site
521             Args : Another datum to calculate the distance to
522             Comments: Assumes the sequences are aligned. Calculates
523             substitutions / total non-missing and non-gapped sites.
524             =cut
525              
526             sub calc_distance {
527 0     0 1 0 my ( $self, $other ) = @_;
528 0         0 my @c1 = $self->get_char;
529 0         0 my @c2 = $other->get_char;
530 0         0 my $t = $self->get_type_object;
531 0         0 my $m = $t->get_missing;
532 0         0 my $g = $t->get_gap;
533 0         0 my $subst = 0;
534 0         0 my $total = 0;
535 0         0 for my $i ( 0 .. $#c1 ) {
536 0 0 0     0 next if $c1[$i] eq $m or $c1[$i] eq $g or $c2[$i] eq $m or $c2[$i] eq $g;
      0        
      0        
537 0         0 $subst += $c1[$i] ne $c2[$i];
538 0         0 $total++;
539             }
540 0 0       0 return $total ? $subst / $total : 9**9**9;
541             }
542              
543             =item calc_state_frequencies()
544              
545             Calculates the frequencies of the states observed in the matrix.
546              
547             Type : Calculation
548             Title : calc_state_frequencies
549             Usage : my %freq = %{ $object->calc_state_frequencies() };
550             Function: Calculates state frequencies
551             Returns : A hash, keys are state symbols, values are frequencies
552             Args : Optional:
553             # if true, counts missing (usually the '?' symbol) as a state
554             # in the final tallies. Otherwise, missing states are ignored
555             -missing => 1
556             # if true, counts gaps (usually the '-' symbol) as a state
557             # in the final tallies. Otherwise, gap states are ignored
558             -gap => 1
559             Comments: Throws exception if matrix holds continuous values
560              
561             =cut
562              
563             sub calc_state_frequencies {
564 5     5 1 10 my $self = shift;
565 5         24 my $counts = $self->calc_state_counts;
566 5         14 my %args = looks_like_hash @_;
567 5         9 for my $arg (qw(missing gap)) {
568 10 50       22 if ( not exists $args{"-${arg}"} ) {
569 10         20 my $method = "get_${arg}";
570 10         28 my $symbol = $self->$method;
571 10         20 delete $counts->{$symbol};
572             }
573             }
574 5         7 my $total = 0;
575 5         6 $total += $_ for values %{$counts};
  5         17  
576 5 50       14 if ( $total > 0 ) {
577 5         7 for my $state ( keys %{$counts} ) {
  5         12  
578 20         30 $counts->{$state} /= $total;
579             }
580             }
581 5         13 return $counts;
582             }
583              
584             =back
585              
586             =head2 METHODS
587              
588             =over
589              
590             =item reverse()
591              
592             Reverses contents.
593              
594             Type : Method
595             Title : reverse
596             Usage : $datum->reverse;
597             Function: Reverses a datum's contained characters
598             Returns : Returns modified $datum
599             Args : NONE
600              
601             =cut
602              
603             sub reverse {
604 0     0 1 0 my $self = shift;
605 0         0 my @char = $self->get_char;
606 0         0 my @reversed = reverse(@char);
607 0         0 $self->set_char( \@reversed );
608             }
609              
610             =item concat()
611              
612             Appends argument to invocant.
613              
614             Type : Method
615             Title : reverse
616             Usage : $datum->concat($datum1);
617             Function: Appends $datum1 to $datum
618             Returns : Returns modified $datum
619             Args : NONE
620              
621             =cut
622              
623             sub concat {
624 0     0 1 0 my ( $self, @data ) = @_;
625 0         0 $logger->info("concatenating objects");
626 0         0 my @newchars;
627 0         0 my @self_chars = $self->get_char;
628 0         0 my $self_i = $self->get_position - 1;
629 0         0 my $self_j = $self->get_length - 1 + $self_i;
630 0         0 @newchars[ $self_i .. $self_j ] = @self_chars;
631 0         0 for my $datum (@data) {
632 0         0 my @chars = $datum->get_char;
633 0         0 my $i = $datum->get_position - 1;
634 0         0 my $j = $datum->get_length - 1 + $i;
635 0         0 @newchars[ $i .. $j ] = @chars;
636             }
637 0         0 my $missing = $self->get_missing;
638 0         0 for my $i ( 0 .. $#newchars ) {
639 0 0       0 $newchars[$i] = $missing if !defined $newchars[$i];
640             }
641 0         0 $self->set_char( \@newchars );
642             }
643              
644             =item consense()
645              
646             Creates consensus sequence out of arguments
647              
648             Type : Method
649             Title : consense
650             Usage : my @chars = $datum->consense($datum1,...);
651             Function: Creates consensus sequence out of arguments
652             Returns : Returns @chars or $seq
653             Args : NONE
654              
655             =cut
656            
657             sub consense {
658 0     0 1 0 my @data = @_;
659            
660             # build two-dimensional array of character states
661 0         0 my @chars;
662 0         0 for my $datum ( @data ) {
663 0         0 my @char = $datum->get_char;
664 0         0 push @chars, \@char;
665             }
666            
667             # get special symbols
668 0         0 my $length = $data[0]->get_length;
669 0         0 my $to = $data[0]->get_type_object;
670 0         0 my $m = $to->get_missing;
671 0         0 my $g = $to->get_gap;
672            
673             # build result
674 0         0 my @result;
675 0         0 for my $i ( 0 .. ( $length - 1 ) ) {
676 0         0 my %col;
677            
678             # get distinct states for column, ignore missing and gap
679 0         0 ROW: for my $row ( @chars ) {
680 0         0 my $c = $row->[$i];
681 0 0 0     0 next ROW if $c eq $m or $c eq $g;
682 0         0 $col{$c} = 1;
683             }
684            
685             # get ambiguity symbol or missing
686 0         0 my @states = keys %col;
687 0 0       0 if ( @states ) {
688 0   0     0 push @result, $to->get_symbol_for_states(@states) || $m;
689             }
690             else {
691 0         0 push @result, $m;
692             }
693             }
694            
695             # return result
696 0 0       0 return wantarray ? @result : $to->join(@result);
697             }
698              
699             =begin comment
700              
701             Validates invocant data contents.
702              
703             Type : Method
704             Title : validate
705             Usage : $datum->validate;
706             Function: Validates character data contained by $datum
707             Returns : True or throws Bio::Phylo::Util::Exceptions::InvalidData
708             Args : NONE
709              
710             =end comment
711              
712             =cut
713              
714             sub _validate {
715 752     752   1115 my $self = shift;
716 752 100       1824 if ( !$self->get_type_object->is_valid($self) ) {
717 3         9 throw 'InvalidData' => 'Invalid data!';
718             }
719             }
720              
721             =item to_xml()
722              
723             Serializes datum to nexml format.
724              
725             Type : Format convertor
726             Title : to_xml
727             Usage : my $xml = $datum->to_xml;
728             Function: Converts datum object into a nexml element structure.
729             Returns : Nexml block (SCALAR).
730             Args : -chars => [] # optional, an array ref of character IDs
731             -states => {} # optional, a hash ref of state IDs
732             -symbols => {} # optional, a hash ref of symbols
733             -special => {} # optional, a hash ref of special symbol IDs
734              
735             =cut
736              
737             sub to_xml {
738 0     0 1 0 my $self = shift;
739 0         0 my %args = looks_like_hash @_;
740 0         0 my $char_ids = $args{'-chars'};
741 0         0 my $state_ids = $args{'-states'};
742 0         0 my $special = $args{'-special'};
743 0 0       0 if ( my $taxon = $self->get_taxon ) {
744 0         0 $self->set_attributes( 'otu' => $taxon->get_xml_id );
745             }
746 0         0 my @char = $self->get_char;
747 0         0 my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap );
748 0         0 my $xml = $self->get_xml_tag;
749 0 0       0 if ( not $args{'-compact'} ) {
750 0         0 for my $i ( 0 .. $#char ) {
751 0         0 my ( $c, $s );
752 0 0 0     0 if ( $missing ne $char[$i] and $gap ne $char[$i] ) {
    0 0        
753 0 0 0     0 if ( $char_ids and $char_ids->[$i] ) {
754 0         0 $c = $char_ids->[$i];
755             }
756             else {
757 0         0 $c = $i;
758             }
759 0 0 0     0 if ( $state_ids and $state_ids->{ uc $char[$i] } ) {
760 0         0 $s = $state_ids->{ uc $char[$i] };
761             }
762             else {
763 0         0 $s = uc $char[$i];
764             }
765             }
766             elsif ( $missing eq $char[$i] or $gap eq $char[$i] ) {
767 0 0 0     0 if ( $char_ids and $char_ids->[$i] ) {
768 0         0 $c = $char_ids->[$i];
769             }
770             else {
771 0         0 $c = $i;
772             }
773 0 0 0     0 if ( $special and $special->{ $char[$i] } ) {
774 0         0 $s = $special->{ $char[$i] };
775             }
776             else {
777 0         0 $s = $char[$i];
778             }
779             }
780              
781             # $cell->set_attributes( 'char' => $c, 'state' => $s );
782             # $xml .= $cell->get_xml_tag(1);
783 0         0 $xml .= sprintf( '', $c, $s );
784             }
785             }
786             else {
787 0         0 my @tmp = map { uc $_ } @char;
  0         0  
788 0         0 my $seq = Bio::Phylo::NeXML::Writable->new(
789             '-tag' => 'seq',
790             '-identifiable' => 0,
791             );
792 0         0 my $seq_text = $self->get_type_object->join( \@tmp );
793 0         0 $xml .=
794             $seq->get_xml_tag . "\n$seq_text\n" . "get_tag . ">";
795             }
796 0         0 $xml .= sprintf( '', $self->get_tag );
797 0         0 return $xml;
798             }
799              
800             =item to_dom()
801              
802             Analog to to_xml.
803              
804             Type : Serializer
805             Title : to_dom
806             Usage : $datum->to_dom
807             Function: Generates a DOM subtree from the invocant
808             and its contained objects
809             Returns : an XML::LibXML::Element object
810             Args : none
811              
812             =cut
813              
814             sub to_dom {
815 0     0 1 0 my $self = shift;
816 0         0 my $dom = $_[0];
817 0         0 my @args = @_;
818              
819             # handle dom factory object...
820 0 0 0     0 if ( looks_like_instance( $dom, 'SCALAR' )
821             && $dom->_type == _DOMCREATOR_ )
822             {
823 0         0 splice( @args, 0, 1 );
824             }
825             else {
826 0         0 $dom = $Bio::Phylo::NeXML::DOM::DOM;
827 0 0       0 unless ($dom) {
828 0         0 throw 'BadArgs' => 'DOM factory object not provided';
829             }
830             }
831             ##### make sure argument handling works here....
832 0         0 my %args = looks_like_hash @args;
833 0         0 my $char_ids = $args{'-chars'};
834 0         0 my $state_ids = $args{'-states'};
835 0         0 my $special = $args{'-special'};
836 0 0       0 if ( my $taxon = $self->get_taxon ) {
837 0         0 $self->set_attributes( 'otu' => $taxon->get_xml_id );
838             }
839 0         0 my @char = $self->get_char;
840 0         0 my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap );
841 0         0 my $elt = $self->get_dom_elt($dom);
842 0 0       0 if ( not $args{'-compact'} ) {
843 0         0 for my $i ( 0 .. $#char ) {
844 0 0 0     0 if ( $missing ne $char[$i] and $gap ne $char[$i] ) {
    0 0        
845 0         0 my ( $c, $s );
846 0 0 0     0 if ( $char_ids and $char_ids->[$i] ) {
847 0         0 $c = $char_ids->[$i];
848             }
849             else {
850 0         0 $c = $i;
851             }
852 0 0 0     0 if ( $state_ids and $state_ids->{ uc $char[$i] } ) {
853 0         0 $s = $state_ids->{ uc $char[$i] };
854             }
855             else {
856 0         0 $s = uc $char[$i];
857             }
858 0         0 my $cell_elt = $dom->create_element( '-tag' => 'cell' );
859 0         0 $cell_elt->set_attributes( 'char' => $c );
860 0         0 $cell_elt->set_attributes( 'state' => $s );
861 0         0 $elt->set_child($cell_elt);
862             }
863             elsif ( $missing eq $char[$i] or $gap eq $char[$i] ) {
864 0         0 my ( $c, $s );
865 0 0 0     0 if ( $char_ids and $char_ids->[$i] ) {
866 0         0 $c = $char_ids->[$i];
867             }
868             else {
869 0         0 $c = $i;
870             }
871 0 0 0     0 if ( $special and $special->{ $char[$i] } ) {
872 0         0 $s = $special->{ $char[$i] };
873             }
874             else {
875 0         0 $s = $char[$i];
876             }
877 0         0 my $cell_elt = $dom->create_element( '-tag' => 'cell' );
878 0         0 $cell_elt->set_attributes( 'char' => $c );
879 0         0 $cell_elt->set_attributes( 'state' => $s );
880 0         0 $elt->set_child($cell_elt);
881             }
882             }
883             }
884             else {
885 0         0 my @tmp = map { uc $_ } @char;
  0         0  
886 0         0 my $seq = $self->get_type_object->join( \@tmp );
887 0         0 my $seq_elt = $dom->create_element( '-tag' => 'seq' );
888             #### create a text node here....
889 0         0 $seq_elt->set_text($seq);
890              
891             #$seq_elt->set_child( XML::LibXML::Text->new($seq) );
892             ####
893 0         0 $elt->set_child($seq_elt);
894             }
895 0         0 return $elt;
896             }
897              
898             =item copy_atts()
899              
900             Not implemented!
901              
902             =cut
903              
904       0 1   sub copy_atts { } # XXX not implemented
905              
906             =item complement()
907              
908             Not implemented!
909              
910             =cut
911              
912       0 1   sub complement { } # XXX not implemented
913              
914             =item slice()
915              
916             Not implemented!
917              
918             =cut
919              
920             sub slice { # XXX not implemented
921 0     0 1 0 my $self = shift;
922 0         0 my $start = int $_[0];
923 0         0 my $end = int $_[1];
924 0         0 my @chars = $self->get_char;
925 0         0 my $pos = $self->get_position;
926 0         0 my $slice - $self->copy_atts;
927             }
928 1488     1488   3429 sub _type { $TYPE_CONSTANT }
929 358     358   638 sub _container { $CONTAINER_CONSTANT }
930 18     18   52 sub _tag { 'row' }
931            
932             sub _update_characters {
933 133     133   204 my $self = shift;
934 133 50       301 if ( my $matrix = $self->get_matrix ) {
935 0           $matrix->_update_characters;
936             }
937             }
938             }
939              
940             =back
941              
942             =cut
943              
944             # podinherit_insert_token
945              
946             =head1 SEE ALSO
947              
948             There is a mailing list at L
949             for any user or developer questions and discussions.
950              
951             =over
952              
953             =item L
954              
955             This object inherits from L, so the methods
956             defined therein are also applicable to L objects.
957              
958             =item L
959              
960             This object inherits from L, so the methods
961             defined therein are also applicable to L objects.
962              
963             =item L
964              
965             Also see the manual: L and L.
966              
967             =back
968              
969             =head1 CITATION
970              
971             If you use Bio::Phylo in published research, please cite it:
972              
973             B, B, B, B
974             and B, 2011. Bio::Phylo - phyloinformatic analysis using Perl.
975             I B<12>:63.
976             L
977              
978             =cut
979              
980             1;
981             __DATA__