view release on metacpan or  search on metacpan

lib/Gibbs.pm  view on Meta::CPAN

# sequence motifs.

# Note: some of the methods in this class print output directly to the terminal via STDERR.
# This can be redirected or captured as desired.

##################################################################################
# The MIT License
#
# Copyright (c) 2022 Matthew H. Seabolt
# TO DO:
# Include a class method to determine the probability of finding a "significant"
# motif of length *k* by random chance, given the length of the sequences that 
# are given to the Gibbs object. This is different from an e-value (e.g. Blast) 
# since that probability is based on the database size.
#
# Permission is hereby granted, free of charge, 
# to any person obtaining a copy of this software and 
# associated documentation files (the "Software"), to 
# deal in the Software without restriction, including 
# without limitation the rights to use, copy, modify, 
# merge, publish, distribute, sublicense, and/or sell 
# copies of the Software, and to permit persons to whom 
# the Software is furnished to do so, 
# subject to the following conditions:
#
# The above copyright notice and this permission notice 
# shall be included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR 
# ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
##################################################################################

package Gibbs;

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw();			 #Import from other packages

use strict;
use warnings;
use List::Util qw(sum min max first);
use Scalar::Util;
use Storable qw(dclone);
use Carp;
our $AUTOLOAD;
use version; our $VERSION = version->declare("v1.1");


################################################################################## 

# Class data and methods 
# Attributes 
{
	# _states and _adj are inherited from Markov parent class
	my %_attribute_properties = (
		_k						=> 3,					# the number of iterations for which nothing changing will be considered convergence, Default 3
		_seqs					=> [ ],					# an anon array containing all the DNA sequences we are searching/sampling from
		_motif_len				=> 7,					# the length of the motif we are searching for, Default 7
		_alphabet				=> '',					# the set of possible symbols available
		_samples				=> [ ],					# a list of the samples we pull, will be updated each iteration
		_profiles				=> [ ],					# a list of the last k profiles, so that we can tell when we've reached convergence
		_t						=> '',					# the number of DNA sequences
		_n 						=> '',					# the length of the DNA sequences
	);
	
	# Global variable counter
	my $_count = 0;
	
	# Return a list of all attributes
	sub _all_attributes	{
		keys %_attribute_properties;
	}
	
	# Return the default value for a given attribute
    sub _attribute_default 	{
     	my( $self, $attribute ) = @_;
        	$_attribute_properties{$attribute};
    	}
    
	# Manage the count of existing objects
	sub get_count	{
		$_count;
	}
	sub _incr_count	{
		++$_count;
	}
	sub _decr_count	{
		--$_count;
	}	
}

############################################################
#                       CONSTRUCTORS                       #
############################################################

# The contructor method
# Construct a new graph (my $node = Markov->new() );
# Returns a scalar reference to a
sub new				{
	my ( $class, %arg ) = @_;
	
	# Create the new object
	my $self = bless {}, $class;

	foreach my $attribute ( $self->_all_attributes() ) {
        	# E.g. attribute = "_name",  argument = "name"
        	my ($argument) = ( $attribute =~ /^_(.*)/ );
        	# If explicitly given
        	if (exists $arg{$argument}) 	{
            	$self->{$attribute} = $arg{$argument};
        	}
        	else	{
            	$self->{$attribute} = $self->_attribute_default($attribute);
        	}
   	}