Bonjour
Voici un code de réseau de neurone pret à l'emploie. Et oui, un de plus...
Néanmoins, j'ai la prétention de dire qu'il est VRAIMENT simple à employer.
Deplus, son implémentation est "propre" et commentée.
Le réseau est constitué d'une seule classe NEURAL_NETWORK.cls
La classe possède les fonctions suivantes :
Construire(T() as variant) as boolean
--> permet de construire le réseau en spécifiant sa strucutre. La fonction a l'avantage d'accepter différentes formes d'entrees.
soit Construire(2,2,1) si on fige les dimensions du réseau
soit Construire(Array(2,2,1)) qui est je l'accorde un équivalent de ce qui précède
mais aussi
Dim T() as variant: redim T(1 to 3)
T(1)=2;T(2)=2:T(3)=3: Construire(T)
cette dernière méthode permet de donner dynamiquement les dimensions du réseau ;)
Apprendre(Es() as variant, Ss() as variant,[Lr,ErrMax,NbCycleMax]) as LEARN_RESULT
fonction d'apprentissage par rétropropagation du gradient des erreurs
Es et Ss sont du même type que T() dans la fonction Construire.
Lr=Learning rate (nombre entre 0 et 0.9999)
ErrMax = L'erreur maximale que l'on souhaite avoir sur "chaque entree"
NbCycleMax = Critère d'arret pour considérer que l'apprentissage ne pourra pas se faire...
la fonction retourne le nombre de cycle si réussite ou un code d'erreur dans le cas contraire
Sauver(add)
sauver le réseau dans un fichier binaire (non éditable facilement)
Charger(add)
charger le réseau depuis un fichier binaire (non éditable facilement)
Propager(Es()) as boolean
Effectuer la propagation pour un vecteur d'entre donne.
Interrompre_Apprentissage()
Permet d'interrompre "imédiatement" le processus d'apprentissage en cours.
Source / Exemple :
Option Explicit
' classe de réseau de neurone de type : perceptron multicouche complètement connectées
'
' implémentation de Flocreate
'
' doccumentation claire : http://www.hacking.free.fr/paris8/Backpropagation.htm
'
' on utilise pour les couches cachées la fonction de tranfert ThanH(x)
' la fonction tangeante hyperbolique a l'avantage d'avoir pour dérivée 1-TanH(x)²
' ceci implique que si on a calculé précédement le TanH(x) on a juste a faire 1-X*X --> gain de temps de calcul
'on utilise une version On-Line (Séquencielle) il faut tirer les cas au hazard
Private Const Bias_Value As Long = 1
'###################################################################################
'###################################################################################
Private nb_c As Long ' contient le nombre de couches
Private Cs() As Long ' contient le nombre de neurone par couche
Private Ws As Variant 'contient la table des poids Ws(couche)((n-1)*Cs(c)+n1)
Private Xs As Variant 'contient la table des sorties des neurones
Private Bs As Variant 'contient la table des Biais des neurones
'###################################################################################
'###################################################################################
Private ARRET As Boolean 'arreter l'apprentissage en cours
Private WE As Boolean 'si l'apprentissage génère des évènements
'evenement généré par l'apprentissage
Public Event Learning(cycle As Long, erreur As Double)
Public Enum LEARN_RESULT
LR_SUCCESS = 0 'success = result > 0
LR_ERROR = -1
LR_NOT_ENOUGHT_CYCLE = -2
LR_STOPED = -3
End Enum
'###################################################################################
'###################################################################################
Public Function Construire(ParamArray Chs() As Variant) As Boolean
' accepte les syntaxes
' Call Construire(nb_n_e, nb_n_c1, nb_n_cn, nb_n_s)
' Call Construire(Array(nb_n_e, nb_n_c1, nb_n_cn, nb_n_s))
' Call Construire(T) 'avec T un tableau de !VARIANT! T={nb_n_e, nb_n_c1, nb_n_cn, nb_n_s}
If (UBound(Chs) >= 1 + LBound(Chs)) Then
'les données sont dans chs
Else
'les données sont potentiellement dans chs(0)
If (UBound(Chs) = -1) Then GoTo erreur 'aucune donnée en entrée -> chs(0) n'existe pas
Dim tmpChs As Variant
On Error GoTo erreur 'type incompatible
tmpChs = Chs(LBound(Chs))
Chs = tmpChs
On Error GoTo 0
'maintenant les données sont dans chs
End If
On Error GoTo erreur
'obtenir le nombre de couche
nb_c = UBound(Chs) - LBound(Chs) + 1
'redimensionner le tableau
ReDim Cs(1 To nb_c)
'retenir le tableau de couche
Dim c As Long, n As Long
For c = 1 To nb_c
Cs(c) = Chs(LBound(Chs) + c - 1)
Next c
'construire les tableaux à partir de la structure Cs()
Call Init_Arrays
Construire = True
Exit Function
erreur:
Construire = False
End Function
'###################################################################################
'construire les tableaux à partir de la structure Cs()
Private Sub Init_Arrays()
Dim Tv() As Variant, Td() As Double
Dim c As Long, n As Long
ReDim Tv(1 To nb_c)
Xs = Tv 'Xs devient un tableau de variants
ReDim Tv(2 To nb_c) 'pas de biais pour la premiere couche qui est une fausse couche
Bs = Tv 'Bs devient un tableau de variants
ReDim Tv(1 To nb_c - 1)
Ws = Tv
For c = 1 To nb_c
ReDim Td(1 To Cs(c))
Xs(c) = Td ' Xs(c) devient un tableau de doubles
If c > 1 Then
Bs(c) = Td ' Bs(c) devient un tableau de doubles
End If
If (c > 1) Then
ReDim Tv(1 To Cs(c - 1))
ReDim Td(1 To Cs(c))
For n = 1 To Cs(c - 1)
Tv(n) = Td
Next n
Ws(c - 1) = Tv
End If
Next c
End Sub
'###################################################################################
'###################################################################################
'###################################################################################
'###################################################################################
'calculer les sorties pour un vecteur d'entree donné
Public Function Propager(ParamArray Entrees() As Variant) As Boolean
On Error GoTo erreur
'fonction de calcul des sorties par propagation des entrées
If ((UBound(Entrees) - LBound(Entrees) + 1) = Cs(1)) Then
'les données sont dans Entrees
Else
'les données sont potentiellement dans Entrees(0)
If (UBound(Entrees) = -1) Then GoTo erreur 'aucune donnée en entrée -> Entrees(0) n'existe pas
Dim tmpEntrees As Variant
On Error GoTo erreur 'type incompatible
tmpEntrees = Entrees(LBound(Entrees))
Entrees = tmpEntrees
On Error GoTo 0
'maintenant les données sont dans Entrees
End If
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim c As Long, n As Long, n1 As Long
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'1) placer les entrées sur la fausse couche dite d'entrée
For n = 1 To Cs(1)
Xs(1)(n) = Entrees(LBound(Entrees) + n - 1)
Next n
'2) pour chaque couche en partant de la premiere vers la derniere,
' calculer la valeur de chaque neurone
' la fonction d'activation des couches est y=Tanh(x) sauf pour la couche cachée qui est y=x
For c = 2 To nb_c 'pour toutes les couches
For n = 1 To Cs(c - 1) 'pour tous les neurones de la couche précédente
For n1 = 1 To Cs(c) 'pour tous les neurones de la couche courrante
If (n = 1) Then
'init avec la valeur du bias
Xs(c)(n1) = Bias_Value * Bs(c)(n1)
End If
'somme pondérée
Xs(c)(n1) = Xs(c)(n1) + Xs(c - 1)(n) * Ws(c - 1)(n)(n1)
Next
Next n
'appliquer la fonction de transfert
If (c < nb_c) Then
For n1 = 1 To Cs(c) 'pour tous les neurones de la couche courrante
Xs(c)(n1) = Tanh(Xs(c)(n1))
Next
End If
Next c
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Propager = True
Exit Function
erreur:
Propager = False
End Function
'###################################################################################
'###################################################################################
Public Sub Interrompre_Apprentissage()
ARRET = True
End Sub
Public Property Get WithEvent() As Boolean
WithEvent = WE
End Property
Public Property Let WithEvent(v As Boolean)
WE = v
End Property
'###################################################################################
'###################################################################################
'Lr = Learning Rate
Public Function Apprendre(Entrees As Variant, Sorties As Variant, Optional Lr As Double = 0.1, _
Optional ErrMax As Double = 0.1, Optional NbCycleMax As Long = 5000) As LEARN_RESULT
ARRET = False
'Etrees et Sorties sont des tableaux de tableaux de variants
Dim nb_cas As Long: nb_cas = UBound(Entrees) - LBound(Entrees) + 1
If (nb_cas <> UBound(Sorties) - LBound(Sorties) + 1) Then GoTo erreur
'init le random
Randomize Time
On Error GoTo erreur
'1) initialiser tous les poids à de petites valeurs
Call Init_Poids
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim c As Long, n As Long, n1 As Long
Dim Cas As Collection, crt_cas As Long, tmp_cas As Long
Dim OK As Boolean, crt_cycle As Long
Dim CrtErr As Double, CrtErrMax As Double, tmpErr As Double
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'jusqu'a ce qu'on ai atteint le seuil d'erreur acceptable ou le nombre de cycle max
While (crt_cycle < NbCycleMax) And Not OK
'passer au nouveau cycle
crt_cycle = crt_cycle + 1
If WE And (crt_cycle Mod (NbCycleMax / 1000) = 1) Then
RaiseEvent Learning(100 * crt_cycle / NbCycleMax, CrtErr)
End If
DoEvents ' permet la modification de la valeur arret
If ARRET = True Then ' arret prématuré demandé
Apprendre = LR_ERROR
Exit Function
End If
OK = True 'par défaut est vrai, un seul cas faux passe à faux
CrtErr = 0
CrtErrMax = 0
'init de la liste de cas
Set Cas = New Collection
For crt_cas = 1 To nb_cas
Cas.add crt_cas
Next crt_cas
'traiter une fois tous les cas mais dans un ordre aléatoire
While (Cas.Count > 0)
' choisir le cas alléatoire dans ceux qui restent à passer pour le cycle
tmp_cas = 1 + CLng(Rnd * (Cas.Count - 1))
crt_cas = Cas(tmp_cas)
Cas.Remove tmp_cas
'-----------------------------------------------------------------------
'Retry:
'2) présenter le cas et propager pour avoir les valeurs
If Not Propager(Entrees(crt_cas)) Then GoTo erreur
'3) corriger un peu les poids pour minimiser l'erreur
Call Corriger(Sorties(LBound(Sorties) + crt_cas - 1), Lr)
' Debug.Print vbTab & Xs(nb_c)(1) & " / " & Sorties(crt_cas)(1)
' DoEvents
'GoTo Retry 'permet de tester la convergence pour un cas isolé des autres
'erreur du cas
tmpErr = Calcul_Err(Sorties(LBound(Sorties) + crt_cas - 1))
'erreur maximale sur le cycle
If (tmpErr > CrtErrMax) Then
CrtErrMax = tmpErr
End If
'erreur moyenne sur le cycle
CrtErr = CrtErr + (tmpErr / nb_cas)
Wend
' Debug.Print crt_cycle & " => " & CrtErr
'OK = CBool(CrtErr < ErrMax) ' erreur moyenne du cycle
OK = CBool(CrtErrMax < ErrMax) ' erreur max du cycle
Wend
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If OK Then
Apprendre = crt_cycle
Else
Apprendre = LR_NOT_ENOUGHT_CYCLE
End If
Exit Function
erreur:
Apprendre = LR_ERROR
End Function
'###################################################################################
Private Function Calcul_Err(Sortie As Variant) As Double
Dim n As Long
For n = 1 To Cs(nb_c)
Calcul_Err = Calcul_Err + _
(Abs(Sortie(LBound(Sortie) + n - 1) - Xs(nb_c)(n)) / Cs(nb_c))
Next n
End Function
Private Sub Corriger(Sortie As Variant, Lr As Double)
Dim c As Long, n As Long, n1 As Long
Dim ERs As Variant: ERs = Xs 'copie pour avoir la meme structure
'calculer les erreurs
For c = nb_c To 2 Step -1
If (c = nb_c) Then
'couche de sortie
For n = 1 To Cs(nb_c)
'Err = ( voule - obtenue ) * f'(a)
ERs(c)(n) = (Sortie(LBound(Sortie) + n - 1) - Xs(c)(n)) * 1
Next n
Else
'couches cachées
For n = 1 To Cs(c)
ERs(c)(n) = 0
For n1 = 1 To Cs(c + 1)
ERs(c)(n) = ERs(c)(n) + ERs(c + 1)(n1) * Ws(c)(n)(n1)
Next n1
ERs(c)(n) = ERs(c)(n) * dTanh(Xs(c)(n))
Next n
End If
Next c
'corriger les erreurs
For c = 2 To nb_c
' If (c = nb_c) Then
'couche de sortie
'corriger les poids qui arrivent sur la couche courrante
For n = 1 To Cs(c - 1)
For n1 = 1 To Cs(c)
Ws(c - 1)(n)(n1) = Ws(c - 1)(n)(n1) _
+ ERs(c)(n1) * Xs(c - 1)(n) * Lr
Next n1
Next n
'corriger les poids des biais de la couche courrante
For n1 = 1 To Cs(c)
Bs(c)(n1) = Bs(c)(n1) _
+ ERs(c)(n1) * Bias_Value * Lr
Next n1
Next c
Set ERs = Nothing
End Sub
'###################################################################################
'###################################################################################
'###################################################################################
'###################################################################################
Private Sub Init_Poids()
Dim c As Long, n As Long, n1 As Long
'initialiser tous les poids entre -0.5 et 0.5
For c = 1 To nb_c - 1
For n = 1 To Cs(c)
For n1 = 1 To Cs(c + 1)
Ws(c)(n)(n1) = Rnd - 0.5
Next n1
Next n
Next c
'initialiser tous les bias entre -0.5 et 0.5
For c = 2 To nb_c
For n = 1 To Cs(c)
Bs(c)(n) = Rnd - 0.5
Next n
Next c
End Sub
'###################################################################################
'###################################################################################
'###################################################################################
'###################################################################################
'charger le réseau depuis un fichier d'extension .NNF (neural network file)
Public Function Charger(add As String) As Boolean
'On Error GoTo erreur
Dim canal As Byte
canal = FreeFile 'allouer un canal de flux libre
Open add For Binary Access Read As #canal 'ouvrire le fichier en mode binaire pour écriture
'lire la constitution du réseau (couches)
Get #canal, , nb_c
ReDim Cs(1 To nb_c)
Get #canal, , Cs
'lire les données
Get #canal, , Ws
Get #canal, , Xs
Get #canal, , Bs
Close #canal 'fermer l'acces au fichier
Charger = True
Exit Function
erreur:
Charger = False
If (canal <> 0) Then Close #canal 'fermer l'acces au fichier si cela n'a pas encore été fait
End Function
'###################################################################################
'###################################################################################
'sauver le réseau dans un fichier d'extension .NNF (neural network file)
Public Function Sauver(add As String) As Boolean
'On Error GoTo erreur
Dim canal As Byte
canal = FreeFile 'allouer un canal de flux libre
Open add For Binary Access Write As #canal 'ouvrire le fichier en mode binaire pour écriture
'sauvegarde de la structure du réseau
Put #canal, , nb_c
Put #canal, , Cs
'sauvegarde des données
Put #canal, , Ws
Put #canal, , Xs
Put #canal, , Bs
Close #canal 'fermer l'acces au fichier
Sauver = True
Exit Function
erreur:
Sauver = False
If (canal <> 0) Then Close #canal 'fermer l'acces au fichier si cela n'a pas encore été fait
End Function
'###################################################################################
'###################################################################################
'###################################################################################
'###################################################################################
Public Property Get nb_couche() As Long
nb_couche = nb_c
End Property
Public Property Get nb_neurone(id_couche As Long) As Long
nb_neurone = Cs(id_couche)
End Property
'###################################################################################
'###################################################################################
Public Property Get Couche(id_couche As Long) As Variant
Couche = Xs(id_couche)
End Property
'###################################################################################
'###################################################################################
'###################################################################################
'###################################################################################
'pour les couches cachées
Private Function Tanh(x As Variant) As Double
On Error GoTo erreur
Tanh = (Exp(x) - Exp(-x)) / (Exp(x) + Exp(-x))
Exit Function
erreur:
If (x > 0) Then
Tanh = 1
Else
Tanh = -1
End If
End Function
Private Function dTanh(tanh_x As Variant) As Double
dTanh = 1 - (tanh_x * tanh_x)
End Function
'###################################################################################
'###################################################################################
Conclusion :
Fonctionne parfaitement sur les classiques AND OR XOR pour plusieurs structures de réseaux et brones différents.
La correction des erreurs est de degré 1, on pourrait le faire évoluer facilement en degré deux qui permet normalement d'éviter l'arrêt sur un minimum local.
Il y a une interface simple avec des exemples d'utilisation.
Vos remarques sont les bienvenues pour améliorer ce programme.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.