Bio::Phylo::Matrices::Datum - Character state sequence

 use Bio::Phylo::Factory;
 my $fac = Bio::Phylo::Factory->new;

 # instantiating a datum object...
 my $datum = $fac->create_datum(
    -name   => 'Tooth comb size,
    -type   => 'STANDARD',
    -desc   => 'number of teeth in lower jaw comb',
    -pos    => 1,
    -weight => 2,
    -char   => [ 6 ],
 );

 # ...and linking it to a taxon object
 my $taxon = $fac->create_taxon(
     -name => 'Lemur_catta'
 );
 $datum->set_taxon( $taxon );

 # instantiating a matrix...
 my $matrix = $fac->create_matrix;

 # ...and insert datum in matrix
 $matrix->insert($datum);

 $Id: Datum.pm 1660 2011-04-02 18:29:40Z rvos $

# $Id: Datum.pm 1660 2011-04-02 18:29:40Z rvos $
package Bio::Phylo::Matrices::Datum;
use strict;
use base qw'Bio::Phylo::Matrices::TypeSafeData Bio::Phylo::Taxa::TaxonLinker';
use Bio::Phylo::Util::OptionalInterface 'Bio::Seq';
use Bio::Phylo::Util::Exceptions 'throw';
use Bio::Phylo::Util::CONSTANT qw':objecttypes /looks_like/';
use Bio::Phylo::NeXML::Writable;
use Bio::Phylo::Factory;
my $LOADED_WRAPPERS = 0;
{
    my $fac                = Bio::Phylo::Factory->new;
    my $logger             = __PACKAGE__->get_logger;
    my $TYPE_CONSTANT      = _DATUM_;
    my $CONTAINER_CONSTANT = _MATRIX_;
    my @fields             = \( my ( %weight, %position, %annotations ) );

    sub new {

        # could be child class
        my $class = shift;

        # notify user
        $logger->info("constructor called for '$class'");
        if ( not $LOADED_WRAPPERS ) {
            eval do { local $/; <DATA> };
            die $@ if $@;
            $LOADED_WRAPPERS++;
        }

        # go up inheritance tree, eventually get an ID
        my $self = $class->SUPER::new(
            @_,
            '-listener' => \&_update_characters,
        );
        return $self;
    }

    sub new_from_bioperl {
        my ( $class, $seq, @args ) = @_;

        # want $seq type-check here? Allowable: is-a Bio::PrimarySeq,
        #  Bio::LocatableSeq /maj
        my $type = $seq->alphabet || $seq->_guess_alphabet || 'dna';
        my $self = $class->new( '-type' => $type, @args );

        # copy seq string
        my $seqstring = $seq->seq;
        if ( $seqstring and $seqstring =~ /\S/ ) {
            eval { $self->set_char($seqstring) };
            if (
                $@
                and looks_like_instance(
                    $@, 'Bio::Phylo::Util::Exceptions::InvalidData'
                )
              )
            {
                $logger->error(
"\nAn exception of type Bio::Phylo::Util::Exceptions::InvalidData was caught\n\n"
                      . $@->description
                      . "\n\nThe BioPerl sequence object contains invalid data ($seqstring)\n"
                      . "I cannot store this string, I will continue instantiating an empty object.\n"
                      . "---------------------------------- STACK ----------------------------------\n"
                      . $@->trace->as_string
                      . "\n--------------------------------------------------------------------------"
                );
            }
        }

        # copy name
        my $name = $seq->display_id;
        $self->set_name($name) if defined $name;

        # copy desc
        my $desc = $seq->desc;
        $self->set_desc($desc) if defined $desc;

        # only Bio::LocatableSeq objs have these fields...
        for my $field (qw(start end strand)) {
            $self->$field( $seq->$field ) if $seq->can($field);
        }
        return $self;
    }

    sub set_weight {
        my ( $self, $weight ) = @_;
        my $id = $self->get_id;
        $weight = 1 if not defined $weight;
        if ( looks_like_number $weight ) {
            $weight{$id} = $weight;
            $logger->info("setting weight '$weight'");
        }
        elsif ( !looks_like_number $weight ) {
            throw 'BadNumber' => 'Not a number!';
        }
    }

    sub set_char {
        my $self   = shift;
        my $name   = $self->get_internal_name;
        my $length = ref $_[0] ? join( '', @{ $_[0] } ) : join( '', @_ );
        $logger->info("setting $name $length chars '@_'");
        my @data;
        for my $arg (@_) {
            if ( looks_like_instance( $arg, 'ARRAY' ) ) {
                push @data, @{$arg};
            }
            else {
                push @data, @{ $self->get_type_object->split($arg) };
            }
        }
        my $missing  = $self->get_missing;
        my $position = $self->get_position;
        for ( 1 .. $position - 1 ) {
            unshift @data, $missing;
        }
        my @char = @{ $self->get_entities };    # store old data for rollback
        eval {
            $self->clear;
            $self->insert(@data);
        };
        if ($@) {
            $self->clear;
            eval { $self->insert(@char) };
            undef($@);
            throw 'InvalidData' =>
              sprintf( 'Invalid data for row %s (type %s: %s)',
                $self->get_internal_name, $self->get_type, join( ' ', @data ) );
        }
        $self->set_annotations;
        return $self;
    }

    sub set_position {
        my ( $self, $pos ) = @_;
        $pos = 1 if not defined $pos;
        if ( looks_like_number $pos && $pos >= 1 && $pos / int($pos) == 1 ) {
            $position{ $self->get_id } = $pos;
            $logger->info("setting position '$pos'");
        }
        else {
            throw 'BadNumber' => "'$pos' not a positive integer!";
        }
    }

    sub set_annotation {
        my $self = shift;
        if (@_) {
            my %opt = looks_like_hash @_;
            if ( not exists $opt{'-char'} ) {
                throw 'BadArgs' => "No character to annotate specified!";
            }
            my $i   = $opt{'-char'};
            my $id  = $self->get_id;
            my $pos = $self->get_position;
            my $len = $self->get_length;
            if ( $i > ( $pos + $len ) || $i < $pos ) {
                throw 'OutOfBounds' => "Specified char ($i) does not exist!";
            }
            if ( exists $opt{'-annotation'} ) {
                my $note = $opt{'-annotation'};
                $annotations{$id}->[$i] = {} if !$annotations{$id}->[$i];
                while ( my ( $k, $v ) = each %{$note} ) {
                    $annotations{$id}->[$i]->{$k} = $v;
                }
            }
            else {
                $annotations{$id}->[$i] = undef;
            }
        }
        else {
            throw 'BadArgs' => "No character to annotate specified!";
        }
        return $self;
    }

    sub set_annotations {
        my $self = shift;
        my @anno;
        if ( scalar @_ == 1 and looks_like_instance( $_[0], 'ARRAY' ) ) {
            @anno = @{ $_[0] };
        }
        else {
            @anno = @_;
        }
        my $id = $self->get_id;
        if (@anno) {
            my $max_index = $self->get_length - 1;
            for my $i ( 0 .. $#anno ) {
                if ( $i > $max_index ) {
                    throw 'OutOfBounds' =>
                      "Specified char ($i) does not exist!";
                }
                else {
                    if ( looks_like_instance( $anno[$i], 'HASH' ) ) {
                        $annotations{$id}->[$i] = {}
                          if !$annotations{$id}->[$i];
                        while ( my ( $k, $v ) = each %{ $anno[$i] } ) {
                            $annotations{$id}->[$i]->{$k} = $v;
                        }
                    }
                    else {
                        next;
                    }
                }
            }
        }
        else {
            $annotations{$id} = [];
        }
    }

    sub get_matrix { shift->_get_container }

    sub get_weight {
        my $self   = shift;
        my $weight = $weight{ $self->get_id };
        return defined $weight ? $weight : 1;
    }

    sub get_char {
        my $self = shift;
        my @data = @{ $self->get_entities };
        if (@data) {
            return wantarray ? @data : $self->get_type_object->join( \@data );
        }
        else {
            return wantarray ? () : '';
        }
    }

    sub get_position {
        my $self = shift;
        my $pos  = $position{ $self->get_id };
        return defined $pos ? $pos : 1;
    }

    sub get_annotation {
        my $self = shift;
        my $id   = $self->get_id;
        if (@_) {
            my %opt = looks_like_hash @_;
            if ( not exists $opt{'-char'} ) {
                throw 'BadArgs' =>
                  "No character to return annotation for specified!";
            }
            my $i   = $opt{'-char'};
            my $pos = $self->get_position;
            my $len = $self->get_length;
            if ( $i < $pos || $i > ( $pos + $len ) ) {
                throw 'OutOfBounds' => "Specified char ($i) does not exist!";
            }
            if ( exists $opt{'-key'} ) {
                return $annotations{$id}->[$i]->{ $opt{'-key'} };
            }
            else {
                return $annotations{$id}->[$i];
            }
        }
        else {
            return $annotations{$id};
        }
    }

    sub get_annotations {
        my $self = shift;
        return $annotations{ $self->get_id } || [];
    }

    sub get_length {
        my $self = shift;

        #        $logger->info("Chars: @char");
        if ( my $matrix = $self->_get_container ) {
            return $matrix->get_nchar;
        }
        else {
            return scalar( @{ $self->get_entities } ) + $self->get_position - 1;
        }
    }

    sub get_by_index {
        my ( $self, $index ) = @_;
        $logger->debug($index);
        my $offset = $self->get_position - 1;
        return $self->get_type_object->get_missing if $offset > $index;
        my $val = $self->SUPER::get_by_index( $index - $offset );
        return defined $val ? $val : $self->get_type_object->get_missing;
    }

    sub get_index_of {
        my ( $self, $obj ) = @_;
        my $is_numerical =
          $self->get_type =~ m/^(Continuous|Standard|Restriction)$/;
        my $i = 0;
        for my $ent ( @{ $self->get_entities } ) {
            if ($is_numerical) {
                return $i if $obj == $ent;
            }
            else {
                return $i if $obj eq $ent;
            }
            $i++;
        }
        return;
    }

    sub can_contain {
        my $self = shift;
        my @data = @_;
        if ( my $obj = $self->get_type_object ) {
            if ( $obj->isa('Bio::Phylo::Matrices::Datatype::Mixed') ) {
                my @split;
                for my $datum (@data) {
                    if ( looks_like_implementor( $datum, 'get_char' ) ) {
                        my @tmp = $datum->get_char();
                        my $i   = $datum->get_position() - 1;
                        for (@tmp) {
                            $split[ $i++ ] = $_;
                        }
                    }
                    elsif ( looks_like_instance( $datum, 'ARRAY' ) ) {
                        push @split, @{$datum};
                    }
                    else {
                        my $subtype = $obj->get_type_for_site( scalar(@split) );
                        push @split, @{ $subtype->split($datum) };
                    }
                }

                #return 1;
                for my $i ( 1 .. scalar(@split) ) {
                    my $subtype = $obj->get_type_for_site( $i - 1 );
                    next if $subtype->is_valid( $split[ $i - 1 ] );
                    throw 'InvalidData' => sprintf(
                        'Invalid char %s at pos %s for type %s',
                        $split[ $i - 1 ],
                        $i, $subtype->get_type,
                    );
                }
                return 1;
            }
            else {
                return $obj->is_valid(@data);
            }
        }
        else {
            throw 'API' => "No associated type object found,\n"
              . "this is a bug - please report - thanks";
        }
    }

    sub calc_state_counts {
        my $self = shift;

        # maybe there should be an option to bin continuous values
        # in X categories, and return the frequencies of those?
        if ( $self->get_type =~ /^continuous$/i ) {
            throw 'BadArgs' => 'Matrix holds continuous values';
        }
        my %counts;
        if (@_) {
            my %focus = map { $_ => 1 } @_;
            my @char = $self->get_char;
            for my $c (@char) {
                if ( exists $focus{$c} ) {
                    if ( not exists $counts{$c} ) {
                        $counts{$c} = 1;
                    }
                    else {
                        $counts{$c}++;
                    }
                }
            }
        }
        else {
            my @char = $self->get_char;
            for my $c (@char) {
                if ( not exists $counts{$c} ) {
                    $counts{$c} = 1;
                }
                else {
                    $counts{$c}++;
                }
            }
        }
        return \%counts;
    }

    sub calc_state_frequencies {
        my $self   = shift;
        my $counts = $self->calc_state_counts;
        my %args   = looks_like_hash @_;
        for my $arg (qw(missing gap)) {
            if ( not exists $args{"-${arg}"} ) {
                my $method = "get_${arg}";
                my $symbol = $self->$method;
                delete $counts->{$symbol};
            }
        }
        my $total = 0;
        $total += $_ for values %{$counts};
        if ( $total > 0 ) {
            for my $state ( keys %{$counts} ) {
                $counts->{$state} /= $total;
            }
        }
        return $counts;
    }

    sub reverse {
        my $self     = shift;
        my @char     = $self->get_char;
        my @reversed = reverse(@char);
        $self->set_char( \@reversed );
    }

    sub concat {
        my ( $self, @data ) = @_;
        $logger->info("concatenating objects");
        my @newchars;
        my @self_chars = $self->get_char;
        my $self_i     = $self->get_position - 1;
        my $self_j     = $self->get_length - 1 + $self_i;
        @newchars[ $self_i .. $self_j ] = @self_chars;
        for my $datum (@data) {
            my @chars = $datum->get_char;
            my $i     = $datum->get_position - 1;
            my $j     = $datum->get_length - 1 + $i;
            @newchars[ $i .. $j ] = @chars;
        }
        my $missing = $self->get_missing;
        for my $i ( 0 .. $#newchars ) {
            $newchars[$i] = $missing if !defined $newchars[$i];
        }
        $self->set_char( \@newchars );
    }

    sub _validate {
        my $self = shift;
        if ( !$self->get_type_object->is_valid($self) ) {
            throw 'InvalidData' => 'Invalid data!';
        }
    }

    sub clone {
        my $self = shift;
        my %subs = @_;

        # some extra logic to copy characters from source to target
        $subs{'set_char'} = 0;

        # some logic to copy annotations
        $subs{'set_annotation'} = 0;
        return $self->SUPER::clone(%subs);
    }

    sub to_xml {
        my $self      = shift;
        my %args      = looks_like_hash @_;
        my $char_ids  = $args{'-chars'};
        my $state_ids = $args{'-states'};
        my $special   = $args{'-special'};
        if ( my $taxon = $self->get_taxon ) {
            $self->set_attributes( 'otu' => $taxon->get_xml_id );
        }
        my @char = $self->get_char;
        my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap );
        my $xml = $self->get_xml_tag;
        if ( not $args{'-compact'} ) {
            for my $i ( 0 .. $#char ) {
                my ( $c, $s );
                if ( $missing ne $char[$i] and $gap ne $char[$i] ) {
                    if ( $char_ids and $char_ids->[$i] ) {
                        $c = $char_ids->[$i];
                    }
                    else {
                        $c = $i;
                    }
                    if ( $state_ids and $state_ids->{ uc $char[$i] } ) {
                        $s = $state_ids->{ uc $char[$i] };
                    }
                    else {
                        $s = uc $char[$i];
                    }
                }
                elsif ( $missing eq $char[$i] or $gap eq $char[$i] ) {
                    if ( $char_ids and $char_ids->[$i] ) {
                        $c = $char_ids->[$i];
                    }
                    else {
                        $c = $i;
                    }
                    if ( $special and $special->{ $char[$i] } ) {
                        $s = $special->{ $char[$i] };
                    }
                    else {
                        $s = $char[$i];
                    }
                }

                #			    $cell->set_attributes( 'char' => $c, 'state' => $s );
                #			    $xml .= $cell->get_xml_tag(1);
                $xml .= sprintf( '<cell char="%s" state="%s"/>', $c, $s );
            }
        }
        else {
            my @tmp = map { uc $_ } @char;
            my $seq = Bio::Phylo::NeXML::Writable->new( -tag => 'seq' );
            my $seq_text = $self->get_type_object->join( \@tmp );
            $xml .=
              $seq->get_xml_tag . "\n$seq_text\n" . "</" . $seq->get_tag . ">";
        }
        $xml .= sprintf( '</%s>', $self->get_tag );
        return $xml;
    }

    sub to_dom {
        my $self = shift;
        my $dom  = $_[0];
        my @args = @_;

        # handle dom factory object...
        if ( looks_like_instance( $dom, 'SCALAR' )
            && $dom->_type == _DOMCREATOR_ )
        {
            splice( @args, 0, 1 );
        }
        else {
            $dom = $Bio::Phylo::NeXML::DOM::DOM;
            unless ($dom) {
                throw 'BadArgs' => 'DOM factory object not provided';
            }
        }
        ##### make sure argument handling works here....
        my %args      = looks_like_hash @args;
        my $char_ids  = $args{'-chars'};
        my $state_ids = $args{'-states'};
        my $special   = $args{'-special'};
        if ( my $taxon = $self->get_taxon ) {
            $self->set_attributes( 'otu' => $taxon->get_xml_id );
        }
        my @char = $self->get_char;
        my ( $missing, $gap ) = ( $self->get_missing, $self->get_gap );
        my $elt = $self->get_dom_elt($dom);
        if ( not $args{'-compact'} ) {
            for my $i ( 0 .. $#char ) {
                if ( $missing ne $char[$i] and $gap ne $char[$i] ) {
                    my ( $c, $s );
                    if ( $char_ids and $char_ids->[$i] ) {
                        $c = $char_ids->[$i];
                    }
                    else {
                        $c = $i;
                    }
                    if ( $state_ids and $state_ids->{ uc $char[$i] } ) {
                        $s = $state_ids->{ uc $char[$i] };
                    }
                    else {
                        $s = uc $char[$i];
                    }
                    my $cell_elt = $dom->create_element( '-tag' => 'cell' );
                    $cell_elt->set_attributes( 'char'  => $c );
                    $cell_elt->set_attributes( 'state' => $s );
                    $elt->set_child($cell_elt);
                }
                elsif ( $missing eq $char[$i] or $gap eq $char[$i] ) {
                    my ( $c, $s );
                    if ( $char_ids and $char_ids->[$i] ) {
                        $c = $char_ids->[$i];
                    }
                    else {
                        $c = $i;
                    }
                    if ( $special and $special->{ $char[$i] } ) {
                        $s = $special->{ $char[$i] };
                    }
                    else {
                        $s = $char[$i];
                    }
                    my $cell_elt = $dom->create_element( '-tag' => 'cell' );
                    $cell_elt->set_attributes( 'char'  => $c );
                    $cell_elt->set_attributes( 'state' => $s );
                    $elt->set_child($cell_elt);
                }
            }
        }
        else {
            my @tmp     = map { uc $_ } @char;
            my $seq     = $self->get_type_object->join( \@tmp );
            my $seq_elt = $dom->create_element( '-tag' => 'seq' );
            #### create a text node here....
            $seq_elt->set_text($seq);

            #$seq_elt->set_child( XML::LibXML::Text->new($seq) );
            ####
            $elt->set_child($seq_elt);
        }
        return $elt;
    }

    sub copy_atts { }    # XXX not implemented

    sub complement { }   # XXX not implemented

    sub slice {          # XXX not implemented
        my $self  = shift;
        my $start = int $_[0];
        my $end   = int $_[1];
        my @chars = $self->get_char;
        my $pos   = $self->get_position;
        my $slice - $self->copy_atts;
    }
    sub _type      { $TYPE_CONSTANT }
    sub _container { $CONTAINER_CONSTANT }
    sub _tag       { 'row' }

    sub _cleanup {
        my $self = shift;
        $logger->info("cleaning up '$self'");
        if ( defined( my $id = $self->get_id ) ) {
            for my $field (@fields) {
                delete $field->{$id};
            }
        }
    }
    
    sub _update_characters {
        my $self = shift;
        if ( my $matrix = $self->get_matrix ) {
            $matrix->_update_characters;
        }
    }
}

# podinherit_insert_token

1;
__DATA__

my $DEFAULT_NAME = 'DEFAULT';

sub meta_names {
    my ($self) = @_;
    my @r;
    my $names = $self->get_generic('meta') || {};
    foreach  ( sort keys %{ $names } ) {
        push (@r, $_) unless $_ eq $DEFAULT_NAME;
    }
    unshift @r, $DEFAULT_NAME if $names->{$DEFAULT_NAME};
    return @r;
}

sub get_SeqFeatures { $logger->warn }

sub get_all_SeqFeatures { $logger->warn }

sub feature_count { $logger->warn }

sub seq {
    my $self = shift;
    my $seq = $self->get_char;
    return $seq;
}

# from primary seq
sub subseq {
   my ($self,$start,$end,$replace) = @_;

   if( ref($start) && $start->isa('Bio::LocationI') ) {
       my $loc = $start;
       $replace = $end; # do we really use this anywhere? scary. HL
       my $seq = "";
       foreach my $subloc ($loc->each_Location()) {
	   my $piece = $self->subseq($subloc->start(),
				     $subloc->end(), $replace);
	   if($subloc->strand() < 0) {
	       $piece = Bio::PrimarySeq->new('-seq' => $piece)->revcom()->seq();
	   }
	   $seq .= $piece;
       }
       return $seq;
   } elsif(  defined  $start && defined $end ) {
       if( $start > $end ){
	   $self->throw("Bad start,end parameters. Start [$start] has to be ".
			"less than end [$end]");
       }
       if( $start <= 0 ) {
	   $self->throw("Bad start parameter ($start). Start must be positive.");
       }
       if( $end > $self->length ) {
	   $self->throw("Bad end parameter ($end). End must be less than the total length of sequence (total=".$self->length.")");
       }

       # remove one from start, and then length is end-start
       $start--;
       if( defined $replace ) {
	   return substr( $self->seq(), $start, ($end-$start), $replace);
       } else {
	   return substr( $self->seq(), $start, ($end-$start));
       }
   } else {
       $self->warn("Incorrect parameters to subseq - must be two integers or a Bio::LocationI object. Got:", $self,$start,$end,$replace);
       return;
   }
}

sub write_GFF { $logger->warn }

sub annotation { $logger->warn }

sub species { $logger->warn }

sub primary_seq { $logger->warn }

sub accession_number { $logger->warn }

sub alphabet {
    my $self = shift;
    my $type = $self->get_type;
    return lc $type;
}

sub can_call_new { $logger->warn }

sub desc {
    my ( $self, $desc ) = @_;
    if ( defined $desc ) {
        $self->set_desc( $desc );
    }
    return $self->get_desc;
}

sub display_id { shift->get_name }

sub id { shift->get_name }

sub is_circular { $logger->warn }

sub length { shift->get_length }

sub moltype { shift->alphabet }

sub primary_id { $logger->warn }

sub revcom { $logger->warn }

sub translate { $logger->warn }

sub trunc { $logger->warn }

sub get_nse{
   my ($self,$char1,$char2) = @_;

   $char1 ||= "/";
   $char2 ||= "-";

   $self->throw("Attribute id not set") unless defined($self->id());
   $self->throw("Attribute start not set") unless defined($self->start());
   $self->throw("Attribute end not set") unless defined($self->end());

   return $self->id() . $char1 . $self->start . $char2 . $self->end ;

}

sub strand {
	my ( $self, $strand ) = @_;
	if ( defined $strand ) {
		$self->set_generic( 'strand' => $strand );
	}
	return $self->get_generic( 'strand' );
}

sub start {
	my ( $self, $start ) = @_;
	if ( defined $start ) {
		$self->set_position( $start );
	}
	return $self->get_position;
}

sub end {
	my ( $self, $end ) = @_;
	if ( defined $end ) {
		$self->set_generic( 'end' => $end );
	}
	$end = $self->get_generic( 'end' );
	if ( defined $end ) {
		return $end;
	}
	else {
		return scalar( @{ $self->get_entities } ) + $self->get_position - 1;
	}
}