RÉSEAU DE NEURONE À RÉTROPROPAGATION SÉQUENTIELLE SIMPLE À UTILISER

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
'###################################################################################
'###################################################################################