Soyez le premier à donner votre avis sur cette source.
Vue 11 426 fois - Téléchargée 1 413 fois
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 '################################################################################### '###################################################################################
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.