line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Bio::Phylo::Matrices::Datatype; |
2
|
16
|
|
|
16
|
|
90
|
use strict; |
|
16
|
|
|
|
|
33
|
|
|
16
|
|
|
|
|
404
|
|
3
|
16
|
|
|
16
|
|
72
|
use warnings; |
|
16
|
|
|
|
|
31
|
|
|
16
|
|
|
|
|
383
|
|
4
|
16
|
|
|
16
|
|
74
|
use base 'Bio::Phylo::NeXML::Writable'; |
|
16
|
|
|
|
|
27
|
|
|
16
|
|
|
|
|
1617
|
|
5
|
16
|
|
|
16
|
|
94
|
use Bio::Phylo::Factory; |
|
16
|
|
|
|
|
31
|
|
|
16
|
|
|
|
|
119
|
|
6
|
16
|
|
|
16
|
|
85
|
use Bio::Phylo::Util::Exceptions 'throw'; |
|
16
|
|
|
|
|
30
|
|
|
16
|
|
|
|
|
751
|
|
7
|
16
|
|
|
16
|
|
170
|
use Bio::Phylo::Util::CONSTANT qw'_DOMCREATOR_ _DATATYPE_ /looks_like/'; |
|
16
|
|
|
|
|
32
|
|
|
16
|
|
|
|
|
4212
|
|
8
|
|
|
|
|
|
|
{ |
9
|
|
|
|
|
|
|
my $logger = __PACKAGE__->get_logger; |
10
|
|
|
|
|
|
|
my $fac = Bio::Phylo::Factory->new(); |
11
|
|
|
|
|
|
|
my @fields = \( my ( %lookup, %missing, %gap, %meta ) ); |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
=head1 NAME |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
Bio::Phylo::Matrices::Datatype - Validator of character state data |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 SYNOPSIS |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# No direct usage |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 DESCRIPTION |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
This is a superclass for objects that validate character data. Objects that |
24
|
|
|
|
|
|
|
inherit from this class (typically those in the |
25
|
|
|
|
|
|
|
Bio::Phylo::Matrices::Datatype::* namespace) can check strings and arrays of |
26
|
|
|
|
|
|
|
character data for invalid symbols, and split and join strings and arrays |
27
|
|
|
|
|
|
|
in a way appropriate for the type (on whitespace for continuous data, |
28
|
|
|
|
|
|
|
on single characters for categorical data). |
29
|
|
|
|
|
|
|
L<Bio::Phylo::Matrices::Matrix> objects and L<Bio::Phylo::Matrices::Datum> |
30
|
|
|
|
|
|
|
internally delegate validation of their contents to these datatype objects; |
31
|
|
|
|
|
|
|
there is no normal usage in which you'd have to deal with datatype objects |
32
|
|
|
|
|
|
|
directly. |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=head1 METHODS |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head2 CONSTRUCTOR |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=over |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
=item new() |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
Datatype constructor. |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
Type : Constructor |
45
|
|
|
|
|
|
|
Title : new |
46
|
|
|
|
|
|
|
Usage : No direct usage, is called by TypeSafeData classes; |
47
|
|
|
|
|
|
|
Function: Instantiates a Datatype object |
48
|
|
|
|
|
|
|
Returns : a Bio::Phylo::Matrices::Datatype child class |
49
|
|
|
|
|
|
|
Args : $type (optional, one of continuous, custom, dna, |
50
|
|
|
|
|
|
|
mixed, protein, restriction, rna, standard) |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=cut |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub new : Constructor { |
55
|
837
|
|
|
837
|
1
|
1360
|
my $class = shift; |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# constructor called with type string |
58
|
837
|
100
|
|
|
|
1666
|
if ( $class eq __PACKAGE__ ) { |
59
|
787
|
|
|
|
|
1784
|
my $type = ucfirst( lc(shift) ); |
60
|
787
|
50
|
|
|
|
1777
|
if ( not $type ) { |
61
|
0
|
|
|
|
|
0
|
throw 'BadArgs' => "No subtype specified!"; |
62
|
|
|
|
|
|
|
} |
63
|
787
|
100
|
|
|
|
1628
|
if ( $type eq 'Nucleotide' ) { |
64
|
1
|
|
|
|
|
4
|
$logger->warn("'nucleotide' datatype requested, using 'dna'"); |
65
|
1
|
|
|
|
|
1
|
$type = 'Dna'; |
66
|
|
|
|
|
|
|
} |
67
|
787
|
|
|
|
|
2257
|
return looks_like_class( __PACKAGE__ . '::' . $type ) |
68
|
|
|
|
|
|
|
->SUPER::new(@_); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# constructor called from type subclass |
72
|
|
|
|
|
|
|
else { |
73
|
50
|
|
|
|
|
115
|
my %args = looks_like_hash @_; |
74
|
|
|
|
|
|
|
{ |
75
|
16
|
|
|
16
|
|
156
|
no strict 'refs'; |
|
16
|
|
|
|
|
35
|
|
|
16
|
|
|
|
|
1456
|
|
|
0
|
|
|
|
|
0
|
|
76
|
50
|
|
|
|
|
128
|
$args{'-lookup'} = ${"${class}::LOOKUP"} |
77
|
50
|
50
|
|
|
|
52
|
if ${"${class}::LOOKUP"}; |
|
50
|
|
|
|
|
177
|
|
78
|
50
|
|
|
|
|
121
|
$args{'-missing'} = ${"${class}::MISSING"} |
79
|
50
|
50
|
|
|
|
60
|
if ${"${class}::MISSING"}; |
|
50
|
|
|
|
|
126
|
|
80
|
50
|
100
|
|
|
|
56
|
$args{'-gap'} = ${"${class}::GAP"} if ${"${class}::GAP"}; |
|
10
|
|
|
|
|
23
|
|
|
50
|
|
|
|
|
137
|
|
81
|
16
|
|
|
16
|
|
86
|
use strict; |
|
16
|
|
|
|
|
29
|
|
|
16
|
|
|
|
|
915
|
|
82
|
|
|
|
|
|
|
} |
83
|
50
|
|
|
|
|
69
|
return $class->SUPER::new(%args); |
|
50
|
|
|
|
|
137
|
|
84
|
|
|
|
|
|
|
} |
85
|
16
|
|
|
16
|
|
82
|
} |
|
16
|
|
|
|
|
31
|
|
|
16
|
|
|
|
|
96
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=back |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
=head2 MUTATORS |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
=over |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
=item set_lookup() |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
Sets state lookup table. |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
Type : Mutator |
98
|
|
|
|
|
|
|
Title : set_lookup |
99
|
|
|
|
|
|
|
Usage : $obj->set_lookup($hashref); |
100
|
|
|
|
|
|
|
Function: Sets the state lookup table. |
101
|
|
|
|
|
|
|
Returns : Modified object. |
102
|
|
|
|
|
|
|
Args : Argument must be a hash |
103
|
|
|
|
|
|
|
reference that maps allowed |
104
|
|
|
|
|
|
|
single character symbols |
105
|
|
|
|
|
|
|
(including ambiguity symbols) |
106
|
|
|
|
|
|
|
onto the equivalent set of |
107
|
|
|
|
|
|
|
non-ambiguous symbols |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
=cut |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
sub set_lookup : Clonable { |
112
|
756
|
|
|
756
|
1
|
1359
|
my ( $self, $lookup ) = @_; |
113
|
756
|
|
|
|
|
1502
|
my $id = $self->get_id; |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
# we have a value |
116
|
756
|
50
|
|
|
|
1371
|
if ( defined $lookup ) { |
117
|
756
|
50
|
|
|
|
1616
|
if ( looks_like_instance $lookup, 'HASH' ) { |
118
|
756
|
|
|
|
|
1450
|
$lookup{$id} = $lookup; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
else { |
121
|
0
|
|
|
|
|
0
|
throw 'BadArgs' => "lookup must be a hash reference"; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# no value, so must be a reset |
126
|
|
|
|
|
|
|
else { |
127
|
0
|
|
|
|
|
0
|
$lookup{$id} = $self->get_lookup; |
128
|
|
|
|
|
|
|
} |
129
|
756
|
|
|
|
|
1436
|
return $self; |
130
|
16
|
|
|
16
|
|
4637
|
} |
|
16
|
|
|
|
|
36
|
|
|
16
|
|
|
|
|
54
|
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item set_missing() |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
Sets missing data symbol. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
Type : Mutator |
137
|
|
|
|
|
|
|
Title : set_missing |
138
|
|
|
|
|
|
|
Usage : $obj->set_missing('?'); |
139
|
|
|
|
|
|
|
Function: Sets the symbol for missing data |
140
|
|
|
|
|
|
|
Returns : Modified object. |
141
|
|
|
|
|
|
|
Args : Argument must be a single |
142
|
|
|
|
|
|
|
character, default is '?' |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=cut |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub set_missing : Clonable { |
147
|
109
|
|
|
109
|
1
|
180
|
my ( $self, $missing ) = @_; |
148
|
109
|
|
|
|
|
199
|
my $id = $self->get_id; |
149
|
109
|
50
|
|
|
|
210
|
if ( $missing ne $self->get_gap ) { |
150
|
109
|
|
|
|
|
199
|
$missing{$id} = $missing; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
else { |
153
|
0
|
|
|
|
|
0
|
throw 'BadArgs' => |
154
|
|
|
|
|
|
|
"Missing character '$missing' already in use as gap character"; |
155
|
|
|
|
|
|
|
} |
156
|
109
|
|
|
|
|
202
|
return $self; |
157
|
16
|
|
|
16
|
|
3916
|
} |
|
16
|
|
|
|
|
35
|
|
|
16
|
|
|
|
|
59
|
|
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=item set_gap() |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
Sets gap symbol. |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
Type : Mutator |
164
|
|
|
|
|
|
|
Title : set_gap |
165
|
|
|
|
|
|
|
Usage : $obj->set_gap('-'); |
166
|
|
|
|
|
|
|
Function: Sets the symbol for gaps |
167
|
|
|
|
|
|
|
Returns : Modified object. |
168
|
|
|
|
|
|
|
Args : Argument must be a single |
169
|
|
|
|
|
|
|
character, default is '-' |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
=cut |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
sub set_gap : Clonable { |
174
|
69
|
|
|
69
|
1
|
131
|
my ( $self, $gap ) = @_; |
175
|
69
|
50
|
|
|
|
147
|
if ( not $gap eq $self->get_missing ) { |
176
|
69
|
|
|
|
|
142
|
$gap{ $self->get_id } = $gap; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
else { |
179
|
0
|
|
|
|
|
0
|
throw 'BadArgs' => |
180
|
|
|
|
|
|
|
"Gap character '$gap' already in use as missing character"; |
181
|
|
|
|
|
|
|
} |
182
|
69
|
|
|
|
|
155
|
return $self; |
183
|
16
|
|
|
16
|
|
3710
|
} |
|
16
|
|
|
|
|
33
|
|
|
16
|
|
|
|
|
57
|
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=item set_metas_for_states() |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
Assigns all metadata annotations for all state symbols |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
Type : Mutator |
190
|
|
|
|
|
|
|
Title : set_metas_for_states |
191
|
|
|
|
|
|
|
Usage : $obj->set_metas_for_states({ $state => [ $m1, $m2 ] }); |
192
|
|
|
|
|
|
|
Function: Assigns all metadata annotations for all state symbols |
193
|
|
|
|
|
|
|
Returns : Modified object. |
194
|
|
|
|
|
|
|
Args : A hash reference of state symbols with metadata arrays |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
=cut |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub set_metas_for_states : Clonable { |
199
|
50
|
|
|
50
|
1
|
76
|
my ( $self, $metas ) = @_; |
200
|
50
|
|
|
|
|
94
|
$meta{$self->get_id} = $metas; |
201
|
50
|
|
|
|
|
100
|
return $self; |
202
|
16
|
|
|
16
|
|
3138
|
} |
|
16
|
|
|
|
|
34
|
|
|
16
|
|
|
|
|
60
|
|
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
=item add_meta_for_state() |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
Adds a metadata annotation for a state symbol |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
Type : Mutator |
209
|
|
|
|
|
|
|
Title : add_meta_for_state |
210
|
|
|
|
|
|
|
Usage : $obj->add_meta_for_state($meta,$state); |
211
|
|
|
|
|
|
|
Function: Adds a metadata annotation for a state symbol |
212
|
|
|
|
|
|
|
Returns : Modified object. |
213
|
|
|
|
|
|
|
Args : A Bio::Phylo::NeXML::Meta object and a state symbol |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=cut |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub add_meta_for_state { |
218
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $meta, $state ) = @_; |
219
|
0
|
0
|
|
|
|
0
|
if ( my $lookup = $self->get_lookup ) { |
220
|
0
|
0
|
|
|
|
0
|
if ( exists $lookup->{$state} ) { |
221
|
0
|
|
|
|
|
0
|
my $id = $self->get_id; |
222
|
0
|
0
|
|
|
|
0
|
$meta{$id} = {} if not $meta{$id}; |
223
|
0
|
0
|
|
|
|
0
|
$meta{$id}->{$state} = [] if not $meta{$id}->{$state}; |
224
|
0
|
|
|
|
|
0
|
push @{ $meta{$id}->{$state} }, $meta; |
|
0
|
|
|
|
|
0
|
|
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
else { |
227
|
0
|
|
|
|
|
0
|
$logger->warn( |
228
|
|
|
|
|
|
|
"State '$state' is unknown, can't add annotation"); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
else { |
232
|
0
|
|
|
|
|
0
|
$logger->warn( |
233
|
|
|
|
|
|
|
"This data type has no categorical states to annotate"); |
234
|
|
|
|
|
|
|
} |
235
|
0
|
|
|
|
|
0
|
return $self; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=item remove_meta_for_state() |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
Removes a metadata annotation for a state symbol |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
Type : Mutator |
243
|
|
|
|
|
|
|
Title : remove_meta_for_state |
244
|
|
|
|
|
|
|
Usage : $obj->remove_meta_for_state($meta,$state); |
245
|
|
|
|
|
|
|
Function: Removes a metadata annotation for a state symbol |
246
|
|
|
|
|
|
|
Returns : Modified object. |
247
|
|
|
|
|
|
|
Args : A Bio::Phylo::NeXML::Meta object and a state symbol |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=cut |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub remove_meta_for_state { |
252
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $meta, $state ) = @_; |
253
|
0
|
|
|
|
|
0
|
my $id = $self->get_id; |
254
|
0
|
0
|
0
|
|
|
0
|
if ( $meta{$id} && $meta{$id}->{$state} ) { |
255
|
0
|
|
|
|
|
0
|
my $meta_array = $meta{$id}->{$state}; |
256
|
0
|
|
|
|
|
0
|
my $meta_id = $meta->get_id; |
257
|
0
|
|
|
|
|
0
|
DICT: for my $i ( 0 .. $#{$meta_array} ) { |
|
0
|
|
|
|
|
0
|
|
258
|
0
|
0
|
|
|
|
0
|
if ( $meta_array->[$i]->get_id == $meta_id ) { |
259
|
0
|
|
|
|
|
0
|
splice @{$meta_array}, $i, 1; |
|
0
|
|
|
|
|
0
|
|
260
|
0
|
|
|
|
|
0
|
last DICT; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
else { |
265
|
0
|
|
|
|
|
0
|
$logger->warn( |
266
|
|
|
|
|
|
|
"There are no annotations to remove for state '$state'"); |
267
|
|
|
|
|
|
|
} |
268
|
0
|
|
|
|
|
0
|
return $self; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=back |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=head2 ACCESSORS |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=over |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
=item get_type() |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
Gets data type as string. |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Type : Accessor |
282
|
|
|
|
|
|
|
Title : get_type |
283
|
|
|
|
|
|
|
Usage : my $type = $obj->get_type; |
284
|
|
|
|
|
|
|
Function: Returns the object's datatype |
285
|
|
|
|
|
|
|
Returns : A string |
286
|
|
|
|
|
|
|
Args : None |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
=cut |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub get_type { |
291
|
824
|
|
|
824
|
1
|
1549
|
my $type = ref shift; |
292
|
824
|
|
|
|
|
3301
|
$type =~ s/.*:://; |
293
|
824
|
|
|
|
|
2506
|
return $type; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=item get_ids_for_special_symbols() |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
Gets state-to-id mapping for missing and gap symbols |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
Type : Accessor |
301
|
|
|
|
|
|
|
Title : get_ids_for_special_symbols |
302
|
|
|
|
|
|
|
Usage : my %ids = %{ $obj->get_ids_for_special_symbols }; |
303
|
|
|
|
|
|
|
Function: Returns state-to-id mapping |
304
|
|
|
|
|
|
|
Returns : A hash reference, keyed on symbol, with UID values |
305
|
|
|
|
|
|
|
Args : Optional, a boolean: |
306
|
|
|
|
|
|
|
true => prefix state ids with 's' |
307
|
|
|
|
|
|
|
false => keep ids numerical |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
=cut |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
sub get_ids_for_special_symbols { |
312
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
313
|
0
|
|
|
|
|
0
|
my $ids_for_states = $self->get_ids_for_states; |
314
|
0
|
|
|
|
|
0
|
my @indices = sort { $a <=> $b } values %{$ids_for_states}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
315
|
0
|
|
|
|
|
0
|
my $max_id = $indices[-1]; |
316
|
0
|
|
|
|
|
0
|
my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap ); |
317
|
0
|
|
|
|
|
0
|
my $ids_for_special_symbols = {}; |
318
|
0
|
0
|
|
|
|
0
|
if ( $_[0] ) { |
319
|
0
|
|
|
|
|
0
|
$ids_for_special_symbols->{$gap} = 's' . ++$max_id; |
320
|
0
|
|
|
|
|
0
|
$ids_for_special_symbols->{$missing} = 's' . ++$max_id; |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
else { |
323
|
0
|
|
|
|
|
0
|
$ids_for_special_symbols->{$gap} = ++$max_id; |
324
|
0
|
|
|
|
|
0
|
$ids_for_special_symbols->{$missing} = ++$max_id; |
325
|
|
|
|
|
|
|
} |
326
|
0
|
|
|
|
|
0
|
return $ids_for_special_symbols; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
=item get_ids_for_states() |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
Gets state-to-id mapping |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
Type : Accessor |
334
|
|
|
|
|
|
|
Title : get_ids_for_states |
335
|
|
|
|
|
|
|
Usage : my %ids = %{ $obj->get_ids_for_states }; |
336
|
|
|
|
|
|
|
Function: Returns state-to-id mapping |
337
|
|
|
|
|
|
|
Returns : A hash reference, keyed on symbol, with UID values |
338
|
|
|
|
|
|
|
Args : Optional, a boolean: |
339
|
|
|
|
|
|
|
true => prefix state ids with 's' |
340
|
|
|
|
|
|
|
false => keep ids numerical |
341
|
|
|
|
|
|
|
Note : This returns a mapping to alphanumeric states; special |
342
|
|
|
|
|
|
|
symbols (for missing data and gaps) are handled separately |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=cut |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
sub get_ids_for_states { |
347
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
348
|
0
|
|
|
|
|
0
|
$logger->debug("getting ids for state set $self"); |
349
|
0
|
0
|
|
|
|
0
|
if ( my $lookup = $self->get_lookup ) { |
350
|
0
|
|
|
|
|
0
|
my $ids_for_states = {}; |
351
|
0
|
|
|
|
|
0
|
my ( @symbols, %tmp_cats, $i ); |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# build a list of state symbols: what properties will this |
354
|
|
|
|
|
|
|
# list have? Symbols will be present in order of the |
355
|
|
|
|
|
|
|
# size of the state set to which they belong; within |
356
|
|
|
|
|
|
|
# each of these ranks, the symbols will be in lexical |
357
|
|
|
|
|
|
|
# order. |
358
|
0
|
|
0
|
|
|
0
|
push( @{ $tmp_cats{ @{ $lookup->{$_} } } ||= [] }, $_ ) |
|
0
|
|
|
|
|
0
|
|
359
|
0
|
|
|
|
|
0
|
for grep /^\d+|[a-zA-Z]/, keys %{$lookup}; |
|
0
|
|
|
|
|
0
|
|
360
|
0
|
|
|
|
|
0
|
push( @symbols, sort { $a cmp $b } @{ $tmp_cats{$_} } ) |
|
0
|
|
|
|
|
0
|
|
361
|
0
|
|
|
|
|
0
|
for sort { $a <=> $b } keys %tmp_cats; |
|
0
|
|
|
|
|
0
|
|
362
|
|
|
|
|
|
|
$ids_for_states->{$_} = ( $_[0] ? 's' : '' ) . ( ++$i ) |
363
|
0
|
0
|
|
|
|
0
|
for (@symbols); |
364
|
0
|
|
|
|
|
0
|
return $ids_for_states; |
365
|
|
|
|
|
|
|
} |
366
|
0
|
|
|
|
|
0
|
return {}; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
=item get_states_for_symbol() |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
Gets set of fundamental states for an ambiguity symbol |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
Type : Accessor |
374
|
|
|
|
|
|
|
Title : get_states_for_symbol |
375
|
|
|
|
|
|
|
Usage : my @states = @{ $obj->get_states_for_symbol('N') }; |
376
|
|
|
|
|
|
|
Function: Returns the set of states for an ambiguity symbol |
377
|
|
|
|
|
|
|
Returns : An array ref of symbols |
378
|
|
|
|
|
|
|
Args : An ambiguity symbol |
379
|
|
|
|
|
|
|
Comments: If supplied argument is a fundamental state, an array |
380
|
|
|
|
|
|
|
ref with just that state is returned, e.g. 'A' returns |
381
|
|
|
|
|
|
|
['A'] for DNA and RNA |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=cut |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
sub get_states_for_symbol { |
386
|
82250
|
|
|
82250
|
1
|
114433
|
my ( $self, $symbol ) = @_; |
387
|
82250
|
|
|
|
|
86637
|
my @states; |
388
|
82250
|
50
|
|
|
|
109319
|
if ( my $lookup = $self->get_lookup ) { |
389
|
82250
|
50
|
|
|
|
168261
|
if ( my $map = $lookup->{uc $symbol} ) { |
390
|
82250
|
|
|
|
|
96180
|
@states = @{ $map }; |
|
82250
|
|
|
|
|
127210
|
|
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
} |
393
|
82250
|
|
|
|
|
170148
|
return \@states; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
=item get_symbol_for_states() |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
Gets ambiguity symbol for a set of states |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
Type : Accessor |
401
|
|
|
|
|
|
|
Title : get_symbol_for_states |
402
|
|
|
|
|
|
|
Usage : my $state = $obj->get_symbol_for_states('A','C'); |
403
|
|
|
|
|
|
|
Function: Returns the ambiguity symbol for a set of states |
404
|
|
|
|
|
|
|
Returns : A symbol (SCALAR) |
405
|
|
|
|
|
|
|
Args : A set of symbols |
406
|
|
|
|
|
|
|
Comments: If no symbol exists in the lookup |
407
|
|
|
|
|
|
|
table for the given set of states, |
408
|
|
|
|
|
|
|
a new - numerical - one is created |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
=cut |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
sub get_symbol_for_states { |
413
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
414
|
0
|
|
|
|
|
0
|
my @syms = @_; |
415
|
0
|
|
|
|
|
0
|
my $lookup = $self->get_lookup; |
416
|
0
|
0
|
|
|
|
0
|
if ($lookup) { |
417
|
0
|
|
|
|
|
0
|
my @lookup_syms = keys %{$lookup}; |
|
0
|
|
|
|
|
0
|
|
418
|
0
|
|
|
|
|
0
|
SYM: for my $sym (@lookup_syms) { |
419
|
0
|
|
|
|
|
0
|
my @states = @{ $lookup->{$sym} }; |
|
0
|
|
|
|
|
0
|
|
420
|
0
|
0
|
|
|
|
0
|
if ( scalar @syms == scalar @states ) { |
421
|
0
|
|
|
|
|
0
|
my $seen_all = 0; |
422
|
0
|
|
|
|
|
0
|
for my $i ( 0 .. $#syms ) { |
423
|
0
|
|
|
|
|
0
|
my $seen = 0; |
424
|
0
|
|
|
|
|
0
|
for my $j ( 0 .. $#states ) { |
425
|
0
|
0
|
|
|
|
0
|
if ( $syms[$i] eq $states[$j] ) { |
426
|
0
|
|
|
|
|
0
|
$seen++; |
427
|
0
|
|
|
|
|
0
|
$seen_all++; |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
} |
430
|
0
|
0
|
|
|
|
0
|
next SYM if not $seen; |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
# found existing symbol |
434
|
0
|
0
|
|
|
|
0
|
return $sym if $seen_all == scalar @syms; |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# create new symbol |
439
|
0
|
|
|
|
|
0
|
my $sym; |
440
|
0
|
0
|
|
|
|
0
|
if ( $self->get_type !~ /standard/i ) { |
441
|
0
|
|
|
|
|
0
|
my $sym = 0; |
442
|
0
|
|
|
|
|
0
|
while ( exists $lookup->{$sym} ) { |
443
|
0
|
|
|
|
|
0
|
$sym++; |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
else { |
447
|
0
|
|
|
|
|
0
|
LETTER: for my $char ( 'A' .. 'Z' ) { |
448
|
0
|
0
|
|
|
|
0
|
if ( not exists $lookup->{$char} ) { |
449
|
0
|
|
|
|
|
0
|
$sym = $char; |
450
|
0
|
|
|
|
|
0
|
last LETTER; |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
} |
454
|
0
|
|
|
|
|
0
|
$lookup->{$sym} = \@syms; |
455
|
0
|
|
|
|
|
0
|
$self->set_lookup($lookup); |
456
|
0
|
|
|
|
|
0
|
return $sym; |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
else { |
459
|
0
|
|
|
|
|
0
|
$logger->info("No lookup table!"); |
460
|
0
|
|
|
|
|
0
|
return; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=item get_lookup() |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
Gets state lookup table. |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
Type : Accessor |
469
|
|
|
|
|
|
|
Title : get_lookup |
470
|
|
|
|
|
|
|
Usage : my $lookup = $obj->get_lookup; |
471
|
|
|
|
|
|
|
Function: Returns the object's lookup hash |
472
|
|
|
|
|
|
|
Returns : A hash reference |
473
|
|
|
|
|
|
|
Args : None |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
=cut |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
sub get_lookup { |
478
|
83130
|
|
|
83130
|
1
|
99124
|
my $self = shift; |
479
|
83130
|
|
|
|
|
125982
|
my $id = $self->get_id; |
480
|
83130
|
100
|
|
|
|
127374
|
if ( exists $lookup{$id} ) { |
481
|
82476
|
|
|
|
|
146921
|
return $lookup{$id}; |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
else { |
484
|
654
|
|
|
|
|
892
|
my $class = __PACKAGE__; |
485
|
654
|
|
|
|
|
1527
|
$class .= '::' . $self->get_type; |
486
|
654
|
|
|
|
|
2376
|
$logger->debug("datatype class is $class"); |
487
|
654
|
50
|
|
|
|
1601
|
if ( looks_like_class $class ) { |
488
|
654
|
|
|
|
|
871
|
my $lookup; |
489
|
|
|
|
|
|
|
{ |
490
|
16
|
|
|
16
|
|
17658
|
no strict 'refs'; |
|
16
|
|
|
|
|
38
|
|
|
16
|
|
|
|
|
617
|
|
|
0
|
|
|
|
|
0
|
|
491
|
654
|
|
|
|
|
888
|
$lookup = ${ $class . '::LOOKUP' }; |
|
654
|
|
|
|
|
2623
|
|
492
|
16
|
|
|
16
|
|
91
|
use strict; |
|
16
|
|
|
|
|
29
|
|
|
16
|
|
|
|
|
12636
|
|
493
|
|
|
|
|
|
|
} |
494
|
654
|
|
|
|
|
831
|
$self->set_lookup($lookup); |
|
654
|
|
|
|
|
1736
|
|
495
|
654
|
|
|
|
|
1490
|
return $lookup; |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
=item get_missing() |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
Gets missing data symbol. |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
Type : Accessor |
505
|
|
|
|
|
|
|
Title : get_missing |
506
|
|
|
|
|
|
|
Usage : my $missing = $obj->get_missing; |
507
|
|
|
|
|
|
|
Function: Returns the object's missing data symbol |
508
|
|
|
|
|
|
|
Returns : A string |
509
|
|
|
|
|
|
|
Args : None |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
=cut |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub get_missing { |
514
|
1643
|
|
|
1643
|
1
|
2226
|
my $self = shift; |
515
|
1643
|
|
|
|
|
2949
|
my $missing = $missing{ $self->get_id }; |
516
|
1643
|
100
|
|
|
|
4608
|
return defined $missing ? $missing : '?'; |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
=item get_gap() |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
Gets gap symbol. |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
Type : Accessor |
524
|
|
|
|
|
|
|
Title : get_gap |
525
|
|
|
|
|
|
|
Usage : my $gap = $obj->get_gap; |
526
|
|
|
|
|
|
|
Function: Returns the object's gap symbol |
527
|
|
|
|
|
|
|
Returns : A string |
528
|
|
|
|
|
|
|
Args : None |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
=cut |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
sub get_gap { |
533
|
950
|
|
|
950
|
1
|
1377
|
my $self = shift; |
534
|
950
|
|
|
|
|
1775
|
my $gap = $gap{ $self->get_id }; |
535
|
950
|
100
|
|
|
|
2121
|
return defined $gap ? $gap : '-'; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
=item get_meta_for_state() |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
Gets metadata annotations (if any) for the provided state symbol |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
Type : Accessor |
543
|
|
|
|
|
|
|
Title : get_meta_for_state |
544
|
|
|
|
|
|
|
Usage : my @meta = @{ $obj->get_meta_for_state }; |
545
|
|
|
|
|
|
|
Function: Gets metadata annotations for a state symbol |
546
|
|
|
|
|
|
|
Returns : An array reference of Bio::Phylo::NeXML::Meta objects |
547
|
|
|
|
|
|
|
Args : A state symbol |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
=cut |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
sub get_meta_for_state { |
552
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $state ) = @_; |
553
|
0
|
|
|
|
|
0
|
my $id = $self->get_id; |
554
|
0
|
0
|
0
|
|
|
0
|
if ( $meta{$id} && $meta{$id}->{$state} ) { |
555
|
0
|
|
|
|
|
0
|
return $meta{$id}->{$state}; |
556
|
|
|
|
|
|
|
} |
557
|
0
|
|
|
|
|
0
|
return []; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=item get_metas_for_states() |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
Gets metadata annotations (if any) for all state symbols |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
Type : Accessor |
565
|
|
|
|
|
|
|
Title : get_metas_for_states |
566
|
|
|
|
|
|
|
Usage : my @meta = @{ $obj->get_metas_for_states }; |
567
|
|
|
|
|
|
|
Function: Gets metadata annotations for state symbols |
568
|
|
|
|
|
|
|
Returns : An array reference of Bio::Phylo::NeXML::Meta objects |
569
|
|
|
|
|
|
|
Args : None |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=cut |
572
|
|
|
|
|
|
|
|
573
|
50
|
|
|
50
|
1
|
103
|
sub get_metas_for_states { $meta{shift->get_id} } |
574
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
=back |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
=head2 TESTS |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
=over |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
=item is_ambiguous() |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
Tests whether the supplied state symbol represents an ambiguous (polymorphic |
584
|
|
|
|
|
|
|
or uncertain) state. For example, for the most commonly-used alphabet for |
585
|
|
|
|
|
|
|
DNA states, the symbol 'N' represents complete uncertainty, the actual state |
586
|
|
|
|
|
|
|
could be any of 'A', 'C', 'G' or 'T', and so this method would return a true |
587
|
|
|
|
|
|
|
value. |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
Type : Test |
590
|
|
|
|
|
|
|
Title : is_ambiguous |
591
|
|
|
|
|
|
|
Usage : if ( $obj->is_ambiguous('N') ) { |
592
|
|
|
|
|
|
|
# do something |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
Function: Returns true if argument is an ambiguous state symbol |
595
|
|
|
|
|
|
|
Returns : BOOLEAN |
596
|
|
|
|
|
|
|
Args : A state symbol |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=cut |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
sub is_ambiguous { |
601
|
65
|
|
|
65
|
1
|
167
|
my ( $self, $symbol ) = @_; |
602
|
65
|
100
|
|
|
|
172
|
if ( my $lookup = $self->get_lookup ) { |
603
|
50
|
|
|
|
|
128
|
my $mapping = $lookup->{uc $symbol}; |
604
|
50
|
100
|
66
|
|
|
221
|
if ( $mapping and ref $mapping eq 'ARRAY' ) { |
605
|
39
|
|
|
|
|
84
|
return scalar(@{$mapping}) > 1; |
|
39
|
|
|
|
|
161
|
|
606
|
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
} |
608
|
26
|
|
|
|
|
89
|
return 0; |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=item is_valid() |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
Validates argument. |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
Type : Test |
616
|
|
|
|
|
|
|
Title : is_valid |
617
|
|
|
|
|
|
|
Usage : if ( $obj->is_valid($datum) ) { |
618
|
|
|
|
|
|
|
# do something |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
Function: Returns true if $datum only contains valid characters |
621
|
|
|
|
|
|
|
Returns : BOOLEAN |
622
|
|
|
|
|
|
|
Args : A Bio::Phylo::Matrices::Datum object |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=cut |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
sub is_valid { |
627
|
1451
|
|
|
1451
|
1
|
2187
|
my $self = shift; |
628
|
1451
|
|
|
|
|
1911
|
my @data; |
629
|
1451
|
|
|
|
|
2747
|
ARG: for my $arg (@_) { |
630
|
1451
|
50
|
|
|
|
6177
|
if ( ref $arg eq 'ARRAY' ) { |
|
|
100
|
|
|
|
|
|
631
|
0
|
|
|
|
|
0
|
push @data, @{$arg}; |
|
0
|
|
|
|
|
0
|
|
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
elsif ( UNIVERSAL::can( $arg, 'get_char' ) ) { |
634
|
743
|
|
|
|
|
1756
|
push @data, $arg->get_char; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
else { |
637
|
708
|
50
|
|
|
|
1889
|
if ( length($arg) > 1 ) { |
638
|
0
|
|
|
|
|
0
|
push @data, @{ $self->split($arg) }; |
|
0
|
|
|
|
|
0
|
|
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
else { |
641
|
708
|
|
|
|
|
10747
|
@data = @_; |
642
|
708
|
|
|
|
|
1296
|
last ARG; |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
} |
646
|
1451
|
100
|
|
|
|
4215
|
return 1 if not @data; |
647
|
712
|
|
|
|
|
1545
|
my $lookup = $self->get_lookup; |
648
|
712
|
|
|
|
|
1381
|
my @symbols = ( $self->get_missing, $self->get_gap, keys %{$lookup} ); |
|
712
|
|
|
|
|
3194
|
|
649
|
712
|
|
|
|
|
1515
|
my %symbols = map { $_ => 1 } grep { defined $_ } @symbols; |
|
12480
|
|
|
|
|
18291
|
|
|
12480
|
|
|
|
|
17096
|
|
650
|
712
|
|
|
|
|
1885
|
CHAR_CHECK: for my $char (@data) { |
651
|
82978
|
50
|
|
|
|
113495
|
next CHAR_CHECK if not defined $char; |
652
|
82978
|
100
|
|
|
|
137821
|
next CHAR_CHECK if $symbols{ uc $char }; |
653
|
8
|
|
|
|
|
48
|
return 0; |
654
|
|
|
|
|
|
|
} |
655
|
704
|
|
|
|
|
10867
|
return 1; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
=item is_same() |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
Compares data type objects. |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
Type : Test |
663
|
|
|
|
|
|
|
Title : is_same |
664
|
|
|
|
|
|
|
Usage : if ( $obj->is_same($obj1) ) { |
665
|
|
|
|
|
|
|
# do something |
666
|
|
|
|
|
|
|
} |
667
|
|
|
|
|
|
|
Function: Returns true if $obj1 contains the same validation rules |
668
|
|
|
|
|
|
|
Returns : BOOLEAN |
669
|
|
|
|
|
|
|
Args : A Bio::Phylo::Matrices::Datatype::* object |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
=cut |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
sub is_same { |
674
|
119
|
|
|
119
|
1
|
242
|
my ( $self, $model ) = @_; |
675
|
119
|
|
|
|
|
593
|
$logger->info("Comparing datatype '$self' to '$model'"); |
676
|
119
|
100
|
|
|
|
300
|
return 1 if $self->get_id == $model->get_id; |
677
|
34
|
50
|
|
|
|
79
|
return 0 if $self->get_type ne $model->get_type; |
678
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
# check strings |
680
|
34
|
|
|
|
|
71
|
for my $prop (qw(get_type get_missing get_gap)) { |
681
|
102
|
|
|
|
|
216
|
my ( $self_prop, $model_prop ) = ( $self->$prop, $model->$prop ); |
682
|
102
|
50
|
33
|
|
|
418
|
return 0 |
|
|
|
33
|
|
|
|
|
683
|
|
|
|
|
|
|
if defined $self_prop |
684
|
|
|
|
|
|
|
&& defined $model_prop |
685
|
|
|
|
|
|
|
&& $self_prop ne $model_prop; |
686
|
|
|
|
|
|
|
} |
687
|
34
|
|
|
|
|
77
|
my ( $s_lookup, $m_lookup ) = ( $self->get_lookup, $model->get_lookup ); |
688
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
# one has lookup, other hasn't |
690
|
34
|
50
|
33
|
|
|
128
|
if ( $s_lookup && !$m_lookup ) { |
691
|
0
|
|
|
|
|
0
|
return 0; |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
# both don't have lookup -> are continuous |
695
|
34
|
0
|
33
|
|
|
66
|
if ( !$s_lookup && !$m_lookup ) { |
696
|
0
|
|
|
|
|
0
|
return 1; |
697
|
|
|
|
|
|
|
} |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# get keys |
700
|
34
|
|
|
|
|
51
|
my @s_keys = keys %{$s_lookup}; |
|
34
|
|
|
|
|
123
|
|
701
|
34
|
|
|
|
|
53
|
my @m_keys = keys %{$m_lookup}; |
|
34
|
|
|
|
|
78
|
|
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
# different number of keys |
704
|
34
|
50
|
|
|
|
80
|
if ( scalar(@s_keys) != scalar(@m_keys) ) { |
705
|
0
|
|
|
|
|
0
|
return 0; |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# compare keys |
709
|
34
|
|
|
|
|
60
|
for my $key (@s_keys) { |
710
|
448
|
50
|
|
|
|
649
|
if ( not exists $m_lookup->{$key} ) { |
711
|
0
|
|
|
|
|
0
|
return 0; |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
else { |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
# compare values |
716
|
448
|
|
|
|
|
756
|
my ( %s_vals, %m_vals ); |
717
|
448
|
|
|
|
|
0
|
my ( @s_vals, @m_vals ); |
718
|
448
|
|
|
|
|
473
|
@s_vals = @{ $s_lookup->{$key} }; |
|
448
|
|
|
|
|
689
|
|
719
|
448
|
|
|
|
|
510
|
@m_vals = @{ $m_lookup->{$key} }; |
|
448
|
|
|
|
|
645
|
|
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
# different number of vals |
722
|
448
|
50
|
|
|
|
695
|
if ( scalar(@m_vals) != scalar(@s_vals) ) { |
723
|
0
|
|
|
|
|
0
|
return 0; |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
# make hashes to compare on vals |
727
|
448
|
|
|
|
|
600
|
%s_vals = map { $_ => 1 } @s_vals; |
|
808
|
|
|
|
|
1284
|
|
728
|
448
|
|
|
|
|
576
|
%m_vals = map { $_ => 1 } @m_vals; |
|
808
|
|
|
|
|
1165
|
|
729
|
448
|
|
|
|
|
719
|
for my $val ( keys %s_vals ) { |
730
|
808
|
50
|
|
|
|
1642
|
return 0 if not exists $m_vals{$val}; |
731
|
|
|
|
|
|
|
} |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
} |
734
|
34
|
|
|
|
|
129
|
return 1; |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
=back |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
=head2 UTILITY METHODS |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=over |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
=item split() |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
Splits argument string of characters following appropriate rules. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
Type : Utility method |
748
|
|
|
|
|
|
|
Title : split |
749
|
|
|
|
|
|
|
Usage : $obj->split($string) |
750
|
|
|
|
|
|
|
Function: Splits $string into characters |
751
|
|
|
|
|
|
|
Returns : An array reference of characters |
752
|
|
|
|
|
|
|
Args : A string |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
=cut |
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
sub split { |
757
|
1237
|
|
|
1237
|
1
|
2209
|
my ( $self, $string ) = @_; |
758
|
1237
|
|
|
|
|
71499
|
my @array = CORE::split( /\s*/, $string ); |
759
|
1237
|
|
|
|
|
18023
|
return \@array; |
760
|
|
|
|
|
|
|
} |
761
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
=item join() |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
Joins argument array ref of characters following appropriate rules. |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
Type : Utility method |
767
|
|
|
|
|
|
|
Title : join |
768
|
|
|
|
|
|
|
Usage : $obj->join($arrayref) |
769
|
|
|
|
|
|
|
Function: Joins $arrayref into a string |
770
|
|
|
|
|
|
|
Returns : A string |
771
|
|
|
|
|
|
|
Args : An array reference |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
=cut |
774
|
|
|
|
|
|
|
|
775
|
|
|
|
|
|
|
sub join { |
776
|
40
|
|
|
40
|
1
|
82
|
my ( $self, $array ) = @_; |
777
|
40
|
|
|
|
|
61
|
return CORE::join( '', @{$array} ); |
|
40
|
|
|
|
|
220
|
|
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
sub _cleanup : Destructor { |
781
|
1672
|
|
|
1672
|
|
2382
|
my $self = shift; |
782
|
1672
|
|
|
|
|
5702
|
$logger->debug("cleaning up '$self'"); |
783
|
1672
|
|
|
|
|
3464
|
my $id = $self->get_id; |
784
|
1672
|
|
|
|
|
2983
|
for my $field (@fields) { |
785
|
6688
|
|
|
|
|
10447
|
delete $field->{$id}; |
786
|
|
|
|
|
|
|
} |
787
|
16
|
|
|
16
|
|
120
|
} |
|
16
|
|
|
|
|
38
|
|
|
16
|
|
|
|
|
120
|
|
788
|
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
=back |
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
=head2 SERIALIZERS |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
=over |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
=item to_xml() |
796
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
Writes data type definitions to xml |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
Type : Serializer |
800
|
|
|
|
|
|
|
Title : to_xml |
801
|
|
|
|
|
|
|
Usage : my $xml = $obj->to_xml |
802
|
|
|
|
|
|
|
Function: Writes data type definitions to xml |
803
|
|
|
|
|
|
|
Returns : An xml string representation of data type definition |
804
|
|
|
|
|
|
|
Args : None |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
=cut |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
sub to_xml { |
809
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
810
|
0
|
|
|
|
|
0
|
$logger->debug("writing $self to xml"); |
811
|
0
|
|
|
|
|
0
|
my $xml = ''; |
812
|
0
|
|
0
|
|
|
0
|
my $normalized = $_[0] || {}; |
813
|
0
|
|
|
|
|
0
|
my $polymorphism = $_[1]; |
814
|
0
|
0
|
|
|
|
0
|
if ( my $lookup = $self->get_lookup ) { |
815
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $self->get_xml_tag; |
816
|
0
|
|
|
|
|
0
|
$logger->debug($xml); |
817
|
0
|
|
|
|
|
0
|
my $id_for_state = $self->get_ids_for_states(1); |
818
|
|
|
|
|
|
|
my @states = sort { |
819
|
0
|
|
|
|
|
0
|
my ( $m, $n ); |
820
|
0
|
|
|
|
|
0
|
($m) = $id_for_state->{$a} =~ /([0-9]+)/; |
821
|
0
|
|
|
|
|
0
|
($n) = $id_for_state->{$b} =~ /([0-9]+)/; |
822
|
0
|
|
|
|
|
0
|
$m <=> $n |
823
|
0
|
|
|
|
|
0
|
} keys %{$id_for_state}; |
|
0
|
|
|
|
|
0
|
|
824
|
0
|
|
|
|
|
0
|
for my $state (@states) { |
825
|
0
|
|
|
|
|
0
|
$xml .= |
826
|
|
|
|
|
|
|
$self->_state_to_xml( $state, $id_for_state, $lookup, |
827
|
|
|
|
|
|
|
$normalized, $polymorphism ); |
828
|
|
|
|
|
|
|
} |
829
|
0
|
|
|
|
|
0
|
my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap ); |
830
|
0
|
|
|
|
|
0
|
my $special = $self->get_ids_for_special_symbols; |
831
|
0
|
0
|
|
|
|
0
|
if ( %{$special} ) { |
|
0
|
|
|
|
|
0
|
|
832
|
0
|
|
|
|
|
0
|
my $uss = |
833
|
|
|
|
|
|
|
$fac->create_xmlwritable( '-tag' => 'uncertain_state_set' ); |
834
|
0
|
|
|
|
|
0
|
my $mbr = $fac->create_xmlwritable( |
835
|
|
|
|
|
|
|
'-tag' => 'member', |
836
|
|
|
|
|
|
|
'-identifiable' => 0 |
837
|
|
|
|
|
|
|
); |
838
|
|
|
|
|
|
|
$uss->set_attributes( |
839
|
0
|
|
|
|
|
0
|
'id' => "s" . $special->{$gap}, |
840
|
|
|
|
|
|
|
'symbol' => '-' |
841
|
|
|
|
|
|
|
); |
842
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $uss->get_xml_tag(1); |
843
|
|
|
|
|
|
|
$uss->set_attributes( |
844
|
0
|
|
|
|
|
0
|
'id' => "s" . $special->{$missing}, |
845
|
|
|
|
|
|
|
'symbol' => '?' |
846
|
|
|
|
|
|
|
); |
847
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $uss->get_xml_tag(); |
848
|
0
|
|
|
|
|
0
|
for (@states) { |
849
|
0
|
|
|
|
|
0
|
$mbr->set_attributes( 'state' => $id_for_state->{$_} ); |
850
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $mbr->get_xml_tag(1); |
851
|
|
|
|
|
|
|
} |
852
|
0
|
|
|
|
|
0
|
$mbr->set_attributes( 'state' => "s" . $special->{$gap} ); |
853
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $mbr->get_xml_tag(1); |
854
|
0
|
|
|
|
|
0
|
$xml .= "\n</" . $uss->get_tag . ">"; |
855
|
|
|
|
|
|
|
} |
856
|
0
|
|
|
|
|
0
|
$xml .= "\n</" . $self->get_tag . ">"; |
857
|
|
|
|
|
|
|
} |
858
|
0
|
|
|
|
|
0
|
return $xml; |
859
|
|
|
|
|
|
|
} |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
sub _state_to_xml { |
862
|
0
|
|
|
0
|
|
0
|
my ( $self, $state, $id_for_state, $lookup, $normalized, $polymorphism ) |
863
|
|
|
|
|
|
|
= @_; |
864
|
0
|
|
|
|
|
0
|
my $state_id = $id_for_state->{$state}; |
865
|
0
|
|
|
|
|
0
|
my @mapping = @{ $lookup->{$state} }; |
|
0
|
|
|
|
|
0
|
|
866
|
|
|
|
|
|
|
my $symbol = |
867
|
0
|
0
|
|
|
|
0
|
exists $normalized->{$state} ? $normalized->{$state} : $state; |
868
|
0
|
|
|
|
|
0
|
my $xml = ''; |
869
|
0
|
|
|
|
|
0
|
my $unambiguous = scalar @mapping <= 1; |
870
|
0
|
0
|
|
|
|
0
|
my $tag = |
|
|
0
|
|
|
|
|
|
871
|
|
|
|
|
|
|
$unambiguous ? 'state' |
872
|
|
|
|
|
|
|
: $polymorphism ? 'polymorphic_state_set' |
873
|
|
|
|
|
|
|
: 'uncertain_state_set'; |
874
|
0
|
|
|
|
|
0
|
my $elt = $fac->create_xmlwritable( |
875
|
|
|
|
|
|
|
'-tag' => $tag, |
876
|
|
|
|
|
|
|
'-xml_id' => $state_id, |
877
|
|
|
|
|
|
|
'-attributes' => { 'symbol' => $symbol } |
878
|
|
|
|
|
|
|
); |
879
|
0
|
|
|
|
|
0
|
$elt->add_meta($_) for @{ $self->get_meta_for_state($state) }; |
|
0
|
|
|
|
|
0
|
|
880
|
|
|
|
|
|
|
|
881
|
0
|
0
|
|
|
|
0
|
if ($unambiguous) { |
882
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $elt->get_xml_tag(1); |
883
|
|
|
|
|
|
|
} |
884
|
|
|
|
|
|
|
else { |
885
|
0
|
|
|
|
|
0
|
$xml .= "\n" . $elt->get_xml_tag(); |
886
|
0
|
|
|
|
|
0
|
for (@mapping) { |
887
|
|
|
|
|
|
|
$xml .= $fac->create_xmlwritable( |
888
|
|
|
|
|
|
|
'-tag' => 'member', |
889
|
|
|
|
|
|
|
'-identifiable' => 0, |
890
|
0
|
|
|
|
|
0
|
'-attributes' => { 'state' => $id_for_state->{$_} } |
891
|
|
|
|
|
|
|
)->get_xml_tag(1); |
892
|
|
|
|
|
|
|
} |
893
|
0
|
|
|
|
|
0
|
$xml .= "\n</" . $elt->get_tag . ">"; |
894
|
|
|
|
|
|
|
} |
895
|
0
|
|
|
|
|
0
|
return $xml; |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
=item to_dom() |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
Analog to to_xml. |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
Type : Serializer |
903
|
|
|
|
|
|
|
Title : to_dom |
904
|
|
|
|
|
|
|
Usage : $type->to_dom |
905
|
|
|
|
|
|
|
Function: Generates a DOM subtree from the invocant |
906
|
|
|
|
|
|
|
and its contained objects |
907
|
|
|
|
|
|
|
Returns : an <XML Package>::Element object |
908
|
|
|
|
|
|
|
Args : none |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
=cut |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
sub to_dom { |
913
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
914
|
0
|
|
|
|
|
0
|
my $dom = $_[0]; |
915
|
0
|
|
|
|
|
0
|
my @args = @_; |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
# handle dom factory object... |
918
|
0
|
0
|
0
|
|
|
0
|
if ( looks_like_instance( $dom, 'SCALAR' ) |
919
|
|
|
|
|
|
|
&& $dom->_type == _DOMCREATOR_ ) |
920
|
|
|
|
|
|
|
{ |
921
|
0
|
|
|
|
|
0
|
splice( @args, 0, 1 ); |
922
|
|
|
|
|
|
|
} |
923
|
|
|
|
|
|
|
else { |
924
|
0
|
|
|
|
|
0
|
$dom = $Bio::Phylo::NeXML::DOM::DOM; |
925
|
0
|
0
|
|
|
|
0
|
unless ($dom) { |
926
|
0
|
|
|
|
|
0
|
throw 'BadArgs' => 'DOM factory object not provided'; |
927
|
|
|
|
|
|
|
} |
928
|
|
|
|
|
|
|
} |
929
|
0
|
|
|
|
|
0
|
my $elt; |
930
|
0
|
|
0
|
|
|
0
|
my $normalized = $args[0] || {}; |
931
|
0
|
|
|
|
|
0
|
my $polymorphism = $args[1]; |
932
|
0
|
0
|
|
|
|
0
|
if ( my $lookup = $self->get_lookup ) { |
933
|
0
|
|
|
|
|
0
|
$elt = $self->get_dom_elt($dom); |
934
|
0
|
|
|
|
|
0
|
my $id_for_state = $self->get_ids_for_states; |
935
|
|
|
|
|
|
|
my @states = sort { |
936
|
0
|
|
|
|
|
0
|
my ( $m, $n ); |
937
|
0
|
|
|
|
|
0
|
($m) = $id_for_state->{$a} =~ /([0-9]+)/; |
938
|
0
|
|
|
|
|
0
|
($n) = $id_for_state->{$b} =~ /([0-9]+)/; |
939
|
0
|
|
|
|
|
0
|
$m <=> $n |
940
|
0
|
|
|
|
|
0
|
} keys %{$id_for_state}; |
|
0
|
|
|
|
|
0
|
|
941
|
0
|
|
|
|
|
0
|
keys %{$id_for_state}; |
|
0
|
|
|
|
|
0
|
|
942
|
0
|
|
|
|
|
0
|
my $max_id = 0; |
943
|
0
|
|
|
|
|
0
|
for my $state (@states) { |
944
|
0
|
|
|
|
|
0
|
my $state_id = $id_for_state->{$state}; |
945
|
0
|
|
|
|
|
0
|
$id_for_state->{$state} = 's' . $state_id; |
946
|
0
|
|
|
|
|
0
|
$max_id = $state_id; |
947
|
|
|
|
|
|
|
} |
948
|
0
|
|
|
|
|
0
|
for my $state (@states) { |
949
|
0
|
|
|
|
|
0
|
$elt->set_child( |
950
|
|
|
|
|
|
|
$self->_state_to_dom( |
951
|
|
|
|
|
|
|
$dom, $state, $id_for_state, |
952
|
|
|
|
|
|
|
$lookup, $normalized, $polymorphism |
953
|
|
|
|
|
|
|
) |
954
|
|
|
|
|
|
|
); |
955
|
|
|
|
|
|
|
} |
956
|
0
|
|
|
|
|
0
|
my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap ); |
957
|
0
|
|
|
|
|
0
|
my $special = $self->get_ids_for_special_symbols; |
958
|
0
|
0
|
|
|
|
0
|
if ( %{$special} ) { |
|
0
|
|
|
|
|
0
|
|
959
|
0
|
|
|
|
|
0
|
my $uss; |
960
|
0
|
|
|
|
|
0
|
$uss = $dom->create_element( '-tag' => 'uncertain_state_set' ); |
961
|
0
|
|
|
|
|
0
|
$uss->set_attributes( 'id' => 's' . $special->{$gap} ); |
962
|
0
|
|
|
|
|
0
|
$uss->set_attributes( 'symbol' => '-' ); |
963
|
0
|
|
|
|
|
0
|
$elt->set_child($uss); |
964
|
0
|
|
|
|
|
0
|
$uss = $dom->create_element( '-tag' => 'uncertain_state_set' ); |
965
|
0
|
|
|
|
|
0
|
$uss->set_attributes( 'id' => 's' . $special->{$missing} ); |
966
|
0
|
|
|
|
|
0
|
$uss->set_attributes( 'symbol' => '?' ); |
967
|
0
|
|
|
|
|
0
|
my $mbr; |
968
|
|
|
|
|
|
|
|
969
|
0
|
|
|
|
|
0
|
for (@states) { |
970
|
0
|
|
|
|
|
0
|
$mbr = $dom->create_element( '-tag' => 'member' ); |
971
|
0
|
|
|
|
|
0
|
$mbr->set_attributes( 'state' => $id_for_state->{$_} ); |
972
|
0
|
|
|
|
|
0
|
$uss->set_child($mbr); |
973
|
|
|
|
|
|
|
} |
974
|
0
|
|
|
|
|
0
|
$mbr = $dom->create_element( '-tag' => 'member' ); |
975
|
0
|
|
|
|
|
0
|
$mbr->set_attributes( 'state' => 's' . $special->{$gap} ); |
976
|
0
|
|
|
|
|
0
|
$uss->set_child($mbr); |
977
|
0
|
|
|
|
|
0
|
$elt->set_child($uss); |
978
|
|
|
|
|
|
|
} |
979
|
|
|
|
|
|
|
} |
980
|
0
|
|
|
|
|
0
|
return $elt; |
981
|
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
sub _state_to_dom { |
984
|
0
|
|
|
0
|
|
0
|
my ( $self, $dom, $state, $id_for_state, $lookup, $normalized, |
985
|
|
|
|
|
|
|
$polymorphism ) |
986
|
|
|
|
|
|
|
= @_; |
987
|
0
|
|
|
|
|
0
|
my $state_id = $id_for_state->{$state}; |
988
|
0
|
|
|
|
|
0
|
my @mapping = @{ $lookup->{$state} }; |
|
0
|
|
|
|
|
0
|
|
989
|
|
|
|
|
|
|
my $symbol = |
990
|
0
|
0
|
|
|
|
0
|
exists $normalized->{$state} ? $normalized->{$state} : $state; |
991
|
0
|
|
|
|
|
0
|
my $elt; |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
# has ambiguity mappings |
994
|
0
|
0
|
|
|
|
0
|
if ( scalar @mapping > 1 ) { |
995
|
0
|
0
|
|
|
|
0
|
my $tag = |
996
|
|
|
|
|
|
|
$polymorphism ? 'polymorphic_state_set' : 'uncertain_state_set'; |
997
|
0
|
|
|
|
|
0
|
$elt = $dom->create_element( '-tag' => $tag ); |
998
|
0
|
|
|
|
|
0
|
$elt->set_attributes( 'id' => $state_id ); |
999
|
0
|
|
|
|
|
0
|
$elt->set_attributes( 'symbol' => $symbol ); |
1000
|
0
|
|
|
|
|
0
|
for my $map (@mapping) { |
1001
|
0
|
|
|
|
|
0
|
my $mbr = $dom->create_element( '-tag' => 'member' ); |
1002
|
0
|
|
|
|
|
0
|
$mbr->set_attributes( 'state' => $id_for_state->{$map} ); |
1003
|
0
|
|
|
|
|
0
|
$elt->set_child($mbr); |
1004
|
|
|
|
|
|
|
} |
1005
|
|
|
|
|
|
|
} |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
# no ambiguity |
1008
|
|
|
|
|
|
|
else { |
1009
|
0
|
|
|
|
|
0
|
$elt = $dom->create_element( '-tag' => 'state' ); |
1010
|
0
|
|
|
|
|
0
|
$elt->set_attributes( 'id' => $state_id ); |
1011
|
0
|
|
|
|
|
0
|
$elt->set_attributes( 'symbol' => $symbol ); |
1012
|
|
|
|
|
|
|
} |
1013
|
0
|
|
|
|
|
0
|
return $elt; |
1014
|
|
|
|
|
|
|
} |
1015
|
50
|
|
|
50
|
|
133
|
sub _tag { 'states' } |
1016
|
50
|
|
|
50
|
|
107
|
sub _type { _DATATYPE_ } |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
=back |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
=cut |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
# podinherit_insert_token |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
=head1 SEE ALSO |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
There is a mailing list at L<https://groups.google.com/forum/#!forum/bio-phylo> |
1027
|
|
|
|
|
|
|
for any user or developer questions and discussions. |
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
=over |
1030
|
|
|
|
|
|
|
|
1031
|
|
|
|
|
|
|
=item L<Bio::Phylo> |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
This object inherits from L<Bio::Phylo>, so the methods defined |
1034
|
|
|
|
|
|
|
therein are also applicable to L<Bio::Phylo::Matrices::Datatype> objects. |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
=item L<Bio::Phylo::Manual> |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
Also see the manual: L<Bio::Phylo::Manual> and L<http://rutgervos.blogspot.com>. |
1039
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
=back |
1041
|
|
|
|
|
|
|
|
1042
|
|
|
|
|
|
|
=head1 CITATION |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
If you use Bio::Phylo in published research, please cite it: |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
B<Rutger A Vos>, B<Jason Caravas>, B<Klaas Hartmann>, B<Mark A Jensen> |
1047
|
|
|
|
|
|
|
and B<Chase Miller>, 2011. Bio::Phylo - phyloinformatic analysis using Perl. |
1048
|
|
|
|
|
|
|
I<BMC Bioinformatics> B<12>:63. |
1049
|
|
|
|
|
|
|
L<http://dx.doi.org/10.1186/1471-2105-12-63> |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
=cut |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
1; |