157 lines
2.5 KiB
Perl
157 lines
2.5 KiB
Perl
package Ktree;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
|
|
sub new {
|
|
my $packagename = shift;
|
|
|
|
my $self = { _root => KtreeNode->new("", 0) };
|
|
|
|
bless ($self, $packagename);
|
|
|
|
return($self);
|
|
}
|
|
|
|
sub add_kmer {
|
|
my $self = shift;
|
|
my ($kmer) = @_;
|
|
|
|
|
|
unless (defined $kmer) {
|
|
confess "error, require param kmer";
|
|
}
|
|
|
|
my $root_node = $self->{_root};
|
|
|
|
my @seq = split(//, $kmer);
|
|
|
|
my $node = $root_node;
|
|
do {
|
|
my $char = shift @seq;
|
|
$node = $node->get_child($char);
|
|
} while (@seq);
|
|
|
|
$node->set_val( $node->get_val() + 1 );
|
|
|
|
return;
|
|
}
|
|
|
|
sub report_kmer_counts {
|
|
my $self = shift;
|
|
|
|
my $root_node = $self->{_root};
|
|
|
|
&_recurse_through_kmer_counts("", $root_node);
|
|
|
|
return;
|
|
}
|
|
|
|
sub _recurse_through_kmer_counts {
|
|
my ($prefix, $node) = @_;
|
|
|
|
my $char = $node->get_char();
|
|
|
|
my @children_chars = $node->get_children_chars();
|
|
|
|
if (@children_chars) {
|
|
foreach my $child_char (@children_chars) {
|
|
my $child_node = $node->get_child($child_char);
|
|
&_recurse_through_kmer_counts($prefix . $char, $child_node);
|
|
}
|
|
}
|
|
else {
|
|
# base case
|
|
my $val = $node->get_val();
|
|
print join("\t", $prefix . $char, $val) . "\n";
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
|
|
package KtreeNode;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
|
|
|
|
sub new {
|
|
my $packagename = shift;
|
|
my ($char, $val) = @_;
|
|
|
|
unless (defined $char && defined $val) {
|
|
confess "Error, require (character, val) as parameter";
|
|
}
|
|
|
|
my $self = { char => $char,
|
|
val => $val,
|
|
children => {},
|
|
};
|
|
|
|
bless ($self, $packagename);
|
|
|
|
return($self);
|
|
}
|
|
|
|
|
|
|
|
|
|
####
|
|
sub get_child {
|
|
my $self = shift;
|
|
my ($char) = @_;
|
|
|
|
unless (defined $char) {
|
|
confess "error, parameter 'char' required";
|
|
}
|
|
|
|
my $child = $self->{children}->{$char};
|
|
unless (ref $child) {
|
|
|
|
$child = $self->{children}->{$char} = new KtreeNode($char, 0);
|
|
}
|
|
|
|
return($child);
|
|
}
|
|
|
|
|
|
sub get_children_chars {
|
|
my $self = shift;
|
|
|
|
my @chars = keys %{$self->{children}};
|
|
return(@chars);
|
|
}
|
|
|
|
|
|
sub get_char {
|
|
my $self = shift;
|
|
return($self->{char});
|
|
}
|
|
|
|
|
|
####
|
|
sub get_val {
|
|
my $self = shift;
|
|
return($self->{val});
|
|
}
|
|
|
|
####
|
|
sub set_val {
|
|
my $self = shift;
|
|
my $val = shift;
|
|
unless (defined $val) {
|
|
confess "error, require val as param";
|
|
}
|
|
|
|
$self->{val} = $val;
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
1; #EOM
|