Commit 9d1b785f authored by Vincent Danjean's avatar Vincent Danjean
Browse files

Release 1.0.0


git-svn-id: svn+ssh://imag/users/huron/danjean/svnroot/claire/altree/tags/release-1.0.0@123 cf695345-040a-0410-a956-b889e835fe2e
parent a64a264e
META.yml
Makefile
package ALTree::Base;
###########################################
######## MAIN DATA STRUCTURES #########
###########################################
sub _init {
my $self=shift;
if (@_) {
my %extra = @_;
@$self{keys %extra} = values %extra;
}
}
sub Debug {
my $self=shift;
#print STDERR @_;
}
1;
package ALTree::Chi2;
use strict;
use ALTree::CUtils;
BEGIN {
use Exporter ();
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
# set the version for version checking
#$VERSION = 1.00;
# if using RCS/CVS, this may be preferred
$VERSION = do { my @r = (q$Revision$ =~ /\d+/g);
sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
@ISA = qw(Exporter);
@EXPORT = qw(NON_SIGNIFICATIF SIGNIFICATIF &chi2_significatif &definition_p_chi2 &reech_chi2);
#%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
# your exported package globals go here,
# as well as any optionally exported functions
@EXPORT_OK = qw();
}
#our @EXPORT_OK;
INIT {
}
# exported package globals go here
#our $Var1;
#our %Hashit;
# non-exported package globals go here
#our @more;
#our $stuff;
# initialize package globals, first exported ones
#$Var1 = '';
#%Hashit = ();
# then the others (which are still accessible as $Some::Module::stuff)
#$stuff = '';
#@more = ();
# all file-scoped lexicals must be created before
# the functions below that use them.
# file-private lexicals go here
#my $priv_var = '';
#my %secret_hash = ();
# here's a file-private function as a closure,
# callable as &$priv_func; it cannot be prototyped.
#my $priv_func = sub {
# # stuff goes here.
#};
# make all your functions, whether exported or not;
# remember to put something interesting in the {} stubs
#sub func1 {} # no prototype
#sub func2() {} # proto'd void
#sub func3($$) {} # proto'd to 2 scalars
# this one isn't exported, but could be called!
#sub func4(\%) {} # proto'd to 1 hash ref
END { } # module clean-up code here (global destructor)
use constant NON_SIGNIFICATIF => 0;
use constant SIGNIFICATIF => 1;
use constant PERM => 1000;
##################################################################
# Fonctions de seuil du chi2 (pr-calcul puis stockage dans un tableau)
my ($chi2_p)="chi2_p doit tre initialis !";
#y ($chi2_p)=0.05;
my ($test_prop_p)="test_prop_p doit tre initialis !";
my ($chi2_seuil)=[];
# test de significativit. Doit retourner vrai ou faux.
sub chi2_significatif {
my ($ddl) = shift;
my ($chi2) = shift;
if ($ddl < 1) {
warn "chi[$ddl] asked...\n";
}
if (not defined($chi2_seuil->[$ddl])) {
#my $c=`critchi2 $chi2_p $ddl`+0; # Verif que les 2 appels sont quivalents
$chi2_seuil->[$ddl]=ALTree::CUtils::critchi($chi2_p, $ddl);
#if ($c != $$chi2_seuil[$ddl]) {
# print STDERR "Critchi2 : $c != $$chi2_seuil[$ddl]\n";
#}
#print "chi2_seuil[$ddl]= $$chi2_seuil[$ddl]\n";
#warn "Seuil chi2 non dfini pour ddl $ddl";
#return 0;
}
return ($chi2 > $chi2_seuil->[$ddl]);
}
sub definition_p_chi2
{
my($p)=shift;
my($pprop)=shift;
if (defined $p) {
$chi2_p=$p;
}
if (defined $pprop) {
$test_prop_p=$pprop;
}
}
sub chi2_fisher_significatif
{
my($pvalue)=shift;
return ($pvalue < $chi2_p);
}
##################################################################
# Rchantillonnage
# Quelques variables globales pour aller plus vite (mme si c'est viter
# en gnral)
my(@fils_c);
my(@fils_m);
my($compteur);
my($sum_malade);
my($sum_controle);
my($sum_total);
my($nb_fils);
my(@th_c, @th_m);
my($clades);
sub calcule_chi2
{
my($i, $chi2, $temp);
$chi2=0;
for ($i=0; $i < $nb_fils; $i++){
$temp=($fils_c[$i]-$th_c[$i]);
$chi2+=($temp)*($temp)/$th_c[$i];
$temp=($$clades[$i]-$fils_c[$i]-$th_m[$i]);
$chi2+=($temp)*($temp)/$th_m[$i];
}
#print "Chi2 : $chi2\n";
return $chi2;
}
sub reech_chi2
{
$sum_malade=shift;
$sum_controle=shift;
$sum_total=$sum_malade+$sum_controle;
$nb_fils=shift;
my($chi2_reel)=shift;
$clades=shift;
my($p_val)=0;
my($i, $k);
#my($alea);
# nb_fils correspond en fait a tous les groupes sur lesquelles il faut faire
# le chi2.
# Cet ensemble de groupe a au total: $sum_malade et $sum_controle individus
# (respectivement malades et controles)
# clades est une rfrence sur un tableau contenant les effectifs globaux de
# chaque clade
#print "Reechantillonage chi2 : ddl : ", ($nb_fils-1), " M: $sum_malade C: $sum_controle\n ";
#print "Chi2 rel : $chi2_reel\n";
#print "Clades: ";
#for $i (@{$clades}) { print "$i "; } print "\n";
# Pr calcul des effectifs thoriques
for ($i=0; $i < $nb_fils; $i++){
$th_c[$i]=($sum_controle*$$clades[$i])/($sum_total);
$th_m[$i]=($sum_malade*$$clades[$i])/($sum_total);
}
my($clade, $alea, $malades, $controles);
my($nb_tests)=PERM;
for ($k=1;$k<=$nb_tests; $k++){
$malades=$sum_malade;
$controles=$sum_controle;
for($clade=0; $clade<$nb_fils; $clade++) {
$fils_m[$clade]=0;
$fils_c[$clade]=0;
for($i=0; $i<$$clades[$clade]; $i++) {
$alea=rand($malades+$controles);
if ($alea < $malades) {
$malades--;
$fils_m[$clade]++;
} else {
$controles--;
$fils_c[$clade]++;
}
}
}
if (calcule_chi2 >= $chi2_reel){
$p_val++;
}
}
#DEBUG print "CHI2=$chi2_reel\n";
#print"nb de chi2 non calculable (effectif nul)= $compteur\n";
#DEBUG print "p_val1 = ", $p_val/$nb_tests,"\n";
# print "chi2_p771=$chi2_p\n";
return ($p_val/$nb_tests);
}
sub reech_significatif
{
my($p_val)=shift;
my($nb_tests)=PERM;
#DEBUG print "Chi2P= $chi2_p\n";
#DEBUG print "p= ", $p_val , "\n";
#DEBUG print "test=", $p_val/$nb_tests<=$chi2_p, "\n";
return ($p_val<=$chi2_p);
}
1;
package ALTree::Foret;
################################################################
################################################################
####################### Foret ########################
################################################################
################################################################
use base qw(ALTree::Base ALTree::SiteCollection);
sub New { # [classe]
my $class=shift;
my $self={};
bless($self, $class);
$self->InitSiteCollection();
$self->_init(@_);
$self->Debug("creating Foret\n");
return $self;
}
sub AddTree {
my $self=shift;
push @{$self->{"trees"}}, @_;
}
sub GetTree {
my $self=shift;
my $index=shift;
return $self->{"trees"}->[$index];
}
sub GetTreesList {
my $self=shift;
return @{$self->{"trees"}};
}
sub ProvideSite {
my $self=shift;
my $site_nb=shift;
if (not $self->HasSiteIndex($site_nb)) {
$self->AddSite(ALTree::SitePerForet->New($site_nb));
}
return $self->GetSite($site_nb);
}
sub CalculVi {
my $self=shift;
foreach my $tree ($self->GetTreesList()) {
foreach my $site ($tree->GetSitesList()) {
foreach my $sens ($site->GetSensList()) {
$self->ProvideSite($site->GetSiteNb())
->ProvideSens($sens->GetSensStruct())
->PlusVi($sens->GetVit());
}
}
}
}
sub _EnsureViMax {
my($self)=shift;
if (not exists ($self->{"V_i_max"})) {
my @tab_trie=sort {
$b->GetViMax() <=> $a->GetViMax()}
$self->GetSitesList();
$self->{"V_i_max"}=$tab_trie[0]->GetViMax();
$self->{"V_i_max_tab"}=\@tab_trie;
}
}
sub GetViMax {
my $self=shift;
$self->_EnsureViMax();
return $self->{"V_i_max"};
}
sub GetViMaxSite {
my($self)=shift;
my($index)=shift;
$self->_EnsureViMax();
return $self->{"V_i_max_tab"}->[$index];
}
sub GetViMaxSiteList {
my($self)=shift;
$self->_EnsureViMax();
return @{$self->{"V_i_max_tab"}};
}
sub NbViMaxSite {
my($self)=shift;
$self->_EnsureViMax();
return (scalar @{$self->{"V_i_max_tab"}});
}
sub _EnsureViMaxSens {
my($self)=shift;
if (not exists ($self->{"V_i_max_sens_tab"})) {
my @tab_trie=sort {
$b->GetVi() <=> $a->GetVi()
} map { $_->GetSensList(); } $self->GetSitesList();
#if ($tab_trie[0]->GetVi() != $self->GetViMax()) {
# die "Arghh\n";
#}
$self->{"V_i_max_sens_tab"}=\@tab_trie;
}
}
sub GetViMaxSens {
my($self)=shift;
my($index)=shift;
$self->_EnsureViMaxSens();
return $self->{"V_i_max_sens_tab"}->[$index];
}
sub GetViMaxSensList {
my($self)=shift;
$self->_EnsureViMaxSens();
return @{$self->{"V_i_max_sens_tab"}};
}
sub NbViMaxSens {
my($self)=shift;
$self->_EnsureViMaxSens();
return (scalar @{$self->{"V_i_max_sens_tab"}});
}
1;
package ALTree::Import;
use strict;
use ALTree::Utils;
use ALTree::Input;
use ALTree::Sens;
use ALTree::Tree;
use ALTree::Foret;
use ALTree::Node;
use ALTree::SitePerTree;
use ALTree::SitePerForet;
use ALTree::SiteSensPerForet;
BEGIN {
use Exporter ();
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
# set the version for version checking
#$VERSION = 1.00;
# if using RCS/CVS, this may be preferred
$VERSION = do { my @r = (q$Revision$ =~ /\d+/g);
sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker
@ISA = qw(Exporter);
@EXPORT = qw();
#%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
# your exported package globals go here,
# as well as any optionally exported functions
@EXPORT_OK = qw();
}
#our @EXPORT_OK;
INIT {
}
# exported package globals go here
#our $Var1;
#our %Hashit;
# non-exported package globals go here
#our @more;
#our $stuff;
# initialize package globals, first exported ones
#$Var1 = '';
#%Hashit = ();
# then the others (which are still accessible as $Some::Module::stuff)
#$stuff = '';
#@more = ();
# all file-scoped lexicals must be created before
# the functions below that use them.
# file-private lexicals go here
#my $priv_var = '';
#my %secret_hash = ();
# here's a file-private function as a closure,
# callable as &$priv_func; it cannot be prototyped.
#my $priv_func = sub {
# # stuff goes here.
#};
# make all your functions, whether exported or not;
# remember to put something interesting in the {} stubs
#sub func1 {} # no prototype
#sub func2() {} # proto'd void
#sub func3($$) {} # proto'd to 2 scalars
# this one isn't exported, but could be called!
#sub func4(\%) {} # proto'd to 1 hash ref
END { } # module clean-up code here (global destructor)
##################################################################
# Fonctions de seuil du chi2 (pr-calcul puis stockage dans un tableau)
1;
This diff is collapsed.
package ALTree::Node;
################################################################
################################################################
####################### Node ##########################
################################################################
################################################################
use base 'ALTree::Base';
# Structure Node
# "id" -> String
# "children" -> Array of (Node)
# "father" -> Node
# "apo" -> Hash of ('num_apo' => SiteSens)
# "br_len" -> Integer
# "case" -> Integer
# "control" -> Integer
# "level" -> Integer
# "height" -> Integer
# "sequence" -> string # used only with phylip
# "oldfather" -> Node # aprs fusion des branches nulles (anciennes relations)
# "oldchildren" -> Array of (Node) # aprs fusion des branches nulles (anciennes relations de parent)
# "label" -> string # nom noeuds apres fusion 3+(4) par exemple
# "res_test" -> Array of (TestResults)
#Creation d'une structure
sub New { # [classe] id
my $class=shift;
my $self={};
my $id=shift;
bless($self, $class);
$self->_init("id" => $id, "apo" => {},
"children" => [], @_);
$self->Debug("creating Node $id\n");
return $self;
}
sub GetId {
my $self=shift;
return $self->{"id"};
}
sub SetFather {
my $self=shift;
my $father=shift;
$self->{"father"}=$father;
}
sub GetFather {
my $self=shift;
return $self->{"father"};
}
sub HasFather {
my $self=shift;
return defined($self->{"father"});
}
sub Father {
my $self=shift;
my $newfather=shift;
if (defined($newfather)) {
$self->SetFather($newfather);
}
return $self->GetFather();
}
sub RecordOrigFather {
my $self=shift;
my $father=shift;
if ($self->HasFather()) {
$self->{"orig_father"}=$self->GetFather();
}
}
sub GetOrigFather {
my $self=shift;
if (exists($self->{"orig_father"})) {
return $self->{"orig_father"};
} else {
return $self->GetFather();
}
}
sub SetCase {
my $self=shift;
my $value=shift;
$self->{"case"}=$value;
}
sub GetCase {
my $self=shift;
return $self->{"case"};
}
sub EraseCase {
my $self=shift;
delete($self->{"case"});
}
sub SetControl {
my $self=shift;
my $value=shift;
$self->{"control"}=$value;
}
sub GetControl {
my $self=shift;
return $self->{"control"};
}
sub EraseControl {
my $self=shift;
delete($self->{"control"});
}
sub SetBrLen {
my $self=shift;
my $br_len=shift;
$self->{"br_len"}=$br_len;
}
sub GetBrLen {
my $self=shift;
return $self->{"br_len"};
}
sub HasBrLen {
my $self=shift;
return exists($self->{"br_len"});
}
sub AddOldChild {
my $self=shift;
push @{$self->{"oldchildren"}}, @_;
}
sub GetOldChildrenList {
my $self=shift;
return @{$self->{"oldchildren"}};
}
sub AddChild {
my $self=shift;
push @{$self->{"children"}}, @_;
}
sub GetChildrenList {
my $self=shift;
return @{$self->{"children"}};
}
sub DeleteChild {
my $self=shift;
my $todelete=shift;
my @newchidren=grep {$_ != $todelete} $self->GetChildrenList();
$self->{"children"}=\@newchidren;
return;
# my $children=$self->{"children"};
# my($i);
# for ($i=0; $i<=$#$children; $i++) {
# if ($children->[$i]==$todelete) {
# splice(@{$children}, $i, 1);
# return;
# }
# }
}
sub NbChildren {
my $self=shift;
return scalar(@{$self->{"children"}});
}
sub GetChild {
my $self=shift;
my $index=shift;
return $self->{"children"}->[$index];
}
sub ForgetChildren {
my $self=shift;
$self->{"children"}=[];
}
sub SetSequence {
my($self)=shift;
my($sequence)=shift;