1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
| #!/usr/bin/perl
use strict; use warnings;
my %h_bact;
open(Bact, 'P:/.../H_Bact.txt') or die;
my $Ligne;
# %H_Num => clé : numéro unique valeur : bactérie à un seul fragment correspondante
my %h_num_uniques;
while($Ligne=<Bact>)
{
if ($Ligne =~ /^(\w+)\t([ \d]+) $/i)
{
my @_array = split(' ', $2);
$h_bact{$1}= \@_array;
if(@_array==1){$h_num_uniques{$2}=$1;}
}
}
close (Bact);
open(MvCombi, 'P:/.../MauvaisesCombiTot.txt') or die;
my @a_mauvaises_combinaisons = <MvCombi>;
close (MvCombi);
# Hash %bad_combis :
# clé : un des numéros de @a_mauvaises_combinaisons
# valeurs : liste de numéros complémentaires
my %bad_combis;
my $ko=0;
for my $combi (@a_mauvaises_combinaisons)
{
$combi =~ m/(\d+)_(\d+)/;
push @{$bad_combis{$1}}, $2;
push @{$bad_combis{$2}}, $1;
if((exists $h_num_uniques{$1})&(exists $h_num_uniques{$2}))
{
print "$h_num_uniques{$1} $1 vs $h_num_uniques{$2} $2\n";
$ko=1;
}
if($ko==1){die "Des fragments uniques forment de mauvaises combinaisons\n";}
}
# Tri des bactéries en fonction du nombre de fragments associés (en premier les bactéries ayant le moins de fragments)
# hash %h_sort_bact : clé nombre d'adn associés valeur : array contenant la liste des bactéries ayant ce nombre de fragments
my %h_sort_bact;
foreach my $bact (keys %h_bact)
{
my $n = @{$h_bact{$bact}};
push(@{$h_sort_bact{$n}},$bact);
}
foreach my $nbr_frag (sort {$a<=>$b} keys %h_sort_bact)
{
foreach my $bact (@{$h_sort_bact{$nbr_frag}})
{
for my $adn (@{$h_bact{$bact}})
{
my $update = maybe_delete_uncompatibles($adn); # on supprime de %copy (clone de \%h_bact)les fragments incompatibles
if( defined $update )
{ # %h_bact contient \%h_bact si l'adn traité n'a aucun adn incompatible
%h_bact = %{$update}; # sinon contient \%copy la copie de %h_bact sans les adn incompatibles à l'adn traité
delete_combis($adn); # on supprime cet adn de toutes les liste $bad_combis{$adn2} où il est présent
}
else # en supprimant des adn incompatibles on tombe sur une @{$copy{$bact}} vide
{
delete_one($adn); # renvoie un message avec la bactérie a perdu tous ses fragments
delete_combis($adn); # on supprime cet adn de toutes les liste $bad_combis{$adn2} où il est présent
}
}
}
}
use Data::Dumper;
print Dumper(\%h_bact);
# sous-programme maybe_delete_uncompatibles
# On vérifie que $adn existe dans %bad_combis, qu'il ait bien des fragments qui lui sont incompatibles
# Si oui on crée le hash %copy étant le clone de %h_bact
# On place dans @uncompatibles la liste @{$bad_combis{$adn}}, c'est à dire la liste des adn incompatibles avec cet adn analysé ($adn)
# Pour chaque bactérie de %copy
# - si la bactérie est présente parmi les clés de %finished on passe à la suivante (bactérie déjà traitée à un seul fragment)
# - sinon on place dans $copy{$bact} les adn de @{$copy{$bact}} qui ne sont pas dans @uncompatibles
# on supprime donc de $copy{$bact} les adn incompatibles avec celui qui est analysé
# - si @{$copy{$bact}} est vide, on quitte le sous-programme sans renvoyer de valeur
# Si @{$copy{$bact}} n'est pas vide, on renvoie \%copy qui correspond à @{$copy{$bact} sans les adn incompatibles
# Si il n'y a plus de mauvaises combinaisons associées à notre adn, on renvoie \%h_bact
# module Storable : http://search.cpan.org/~ams/Storable-2.18/Storable.pm
# The Storable package brings persistence to your Perl data structures containing SCALAR, ARRAY, HASH
# or REF objects, i.e.anything that can be conveniently stored to disk and retrieved at a later time
# Storable provides you with a dclone interface which freezes the structure
# in some internal memory space and then immediately thaws it out.
# dclone() signifie deep clone et l'objectif est de faire une copie en profondeur, c'est à dire une copie
# qui copie récursivement le contenu des références contenues dans la structure, une copie qu'on peut modifier sans modifier l'original.
use Storable qw/dclone/;
sub maybe_delete_uncompatibles
{
my $adn = shift;
if( exists $bad_combis{$adn} )
{
my %copy = %{dclone(\%h_bact)};
my @uncompatibles = @{$bad_combis{$adn}};
for my $bact (keys %copy)
{
$copy{$bact} = [grep {not in($_, @uncompatibles)} @{$copy{$bact}}];
return unless @{$copy{$bact}};
}
return \%copy;
}
return \%h_bact;
}
# sous-programme delete_one
# on récupère l'adn problématique qui ne peut pas être supprimé car il crée une bactérie sans adn associés
# on regarde chaque bactérie de %h_bact
# on passe à la suivante si celle-ci est dans %finished
# sinon
# - on supprime de $h_bact{$bact} cet adn problématique
# - on vérifie que @{$h_bact{$bact}} est bien devenu vide et si oui on affiche un message d'erreur
# - permet de savoir laquelle des bactéries de %h_bact pose le problème
sub delete_one {
my $adn = shift;
for my $bact (keys %h_bact)
{
$h_bact{$bact} = [grep {not $adn == $_} @{$h_bact{$bact}}];
die "Tache impossible, la bacterie $bact a perdu tous ses fragments\n"
unless @{$h_bact{$bact}};
}
}
# sous-programme delete_combis
# On vérifie que $adn existe dans %bad_combis
# Si oui on crible un à un les ADN adn2 de @{$bad_combis{$adn}}
# et on supprime de $bad_combis{$adn2} l'adn qui vient d'être traité
sub delete_combis
{
my $adn = shift;
if( exists $bad_combis{$adn} )
{
for my $adn2 (@{$bad_combis{$adn}})
{
$bad_combis{$adn2} = [grep {not $adn == $_} @{$bad_combis{$adn2}}];
}
delete $bad_combis{$adn};
}
}
# tools
# Si tu lui donnes un élément et un tableau, il teste si l'élément est dans le tableau (numériquement).
# sous-programme in
# retourne la première valeur de @_ pour laquelle $searched == $_
# @_ Tableau contenant les paramètres des routines
use List::Util qw/first/;
sub in
{
my $searched = shift;
return first {$searched == $_} @_;
} |
