無限不可能性ドライブ

『ニューラルネットワーク自作入門』に刺激されてExcelVBAでニューラルネットワークを作ってみたものの、やっぱり数学やらなきゃと思い少しずつやってきたのもあって、自分の知識の整理とかそういった感じです。

【VBA編】ニューラルネットワーク（mdlSupervisor）

VBA ニューラルネットワーク

スーパーバイザ

メインの処理となるモジュールです。

'[mdlSupervisor - 標準モジュール]
Option Explicit
Option Base 1

Dim mcInLayer As classInputLayer
Dim mcHLayer1 As classHiddenLayer
Dim mcHLayer2 As classHiddenLayer
Dim mcOutLayer As classOutputLayer

'ユニット数を設定する
'[引数] <- aWsInputData : Worksheet / 入力データのあるシート
'[戻り値] -> なし
Private Sub setUnitCount(ByRef aWsInputData As Worksheet)
    
    With aWsInputData
        G.UnitCount_IN = .Cells(RW.DATA_TITLE, Columns.count).End(xlToLeft).Column - 1
    End With
    
    G.UnitCount_H1 = 3
    G.UnitCount_H2 = 4
    
    G.UnitCount_OUT = 3
    
End Sub

'ユニットを作成する
'[引数] <-　なし
'[戻り値] -> なし
Private Sub makeUnit()
    Dim actHidden As Long
    Dim actOutput As Long
    
    Set mcInLayer = New classInputLayer
    Set mcHLayer1 = New classHiddenLayer
    Set mcHLayer2 = New classHiddenLayer
    Set mcOutLayer = New classOutputLayer
    
    With ws_Main
        actHidden = getActivationFunction(.Range(G.RNG_ACT_HIDDEN).Value)
        actOutput = getActivationFunction(.Range(G.RNG_ACT_OUTPUT).Value)
    End With

    Call mcHLayer1.Initialize(G.UnitCount_H1, G.UnitCount_IN, actHidden)
    Call mcHLayer2.Initialize(G.UnitCount_H2, G.UnitCount_H1, actHidden)
    Call mcOutLayer.Initialize(G.UnitCount_OUT, G.UnitCount_H2, actOutput)
    
End Sub

Public Sub Click_学習開始()
    Call StartTrain
End Sub

Public Sub Click_テスト開始()
    Call StartTest
End Sub

Public Sub Click_学習状況クリア()
    ws_W_H1.Cells.Clear
    ws_W_H2.Cells.Clear
    ws_W_Out.Cells.Clear
    
    Call clearResult
End Sub

Public Sub StartTrain()
    Dim r As Long
    Dim c As Long
    Dim eRow As Long
    Dim eCol As Long
    Dim label As String
    Dim t() As Long
    Dim datas() As Double
    Dim res() As Double
    Dim e As Double
    Dim sumE As Double
    Dim i As Long
    Dim epoc As Long
    Dim minLoss As Double
    Dim maxEpoc As Long
    Dim cnt As Long
    Dim ansIndex As Long
    Dim ansRate As Double

    Call setUnitCount(ws_Train_Data_Input)
    Call makeUnit
    
    With ws_Main
        G.LearningRate = CDbl(.Range(G.RNG_LEARNING_RATE).Value)
        minLoss = CDbl(.Range(G.RNG_MIN_LOSS).Value)
        maxEpoc = CLng(.Range(G.RNG_MAX_EPOCH).Value)
    
        If .Range(G.RNG_W_LOAD).Value = "はい" Then
            Call mcHLayer1.LoadWeight(ws_WI_H1)
            Call mcHLayer2.LoadWeight(ws_WI_H2)
            Call mcOutLayer.LoadWeight(ws_WI_Out)
        Else
            Call mcHLayer1.SaveWeight(ws_WI_H1)
            Call mcHLayer2.SaveWeight(ws_WI_H2)
            Call mcOutLayer.SaveWeight(ws_WI_Out)
        End If
    
    End With
    
    Call clearResult
    
    On Error GoTo ErrorLabel
    
    With ws_Train_Data_Input
    
        eRow = .Cells(Rows.count, 1).End(xlUp).Row
        eCol = .Cells(RW.DATA_TITLE, Columns.count).End(xlToLeft).Column
        
        ReDim datas(eCol - 1)

        Do
        
            epoc = epoc + 1
            
            If epoc > maxEpoc Then
                Exit Do
            End If
            
            sumE = 0
            cnt = 0
    
            For r = 2 To eRow
            
                cnt = cnt + 1
            
                For c = 2 To eCol
                    datas(c - 1) = .Cells(r, c).Value
                Next
            
                label = .Cells(r, CL.DATA_LABEL).Value
                t = getT(G.UnitCount_OUT, label)

                Call mcHLayer1.Forward(datas)
                Call mcHLayer2.Forward(mcHLayer1.OutputDataList)
                Call mcOutLayer.Forward(mcHLayer2.OutputDataList)
                
                ansIndex = mcOutLayer.GetAnswerIndex
                ansRate = mcOutLayer.GetAnswerRate(ansIndex)
                Call getAnswer(ws_Train_Result, r, ansIndex, ansRate, label)
                
                res = mcOutLayer.OutputDataList
            
                e = ML.crossEntropyError(t, res)
                sumE = sumE + e
                
                Call mcOutLayer.Backprop(t)
                
                For i = 1 To G.UnitCount_H2
                    Call mcHLayer2.Backprop(i, mcOutLayer.deltaList, mcOutLayer.GetWeightList(i))
                Next
                
                For i = 1 To G.UnitCount_H1
                    Call mcHLayer1.Backprop(i, mcHLayer2.deltaList, mcHLayer2.GetWeightList(i))
                Next
            
            Next

            With ws_Main
                DoEvents
                .Cells(epoc, CL.LOSS_).Value = (sumE / cnt)
                Application.Calculate
                .Cells(epoc, CL.LOSS_CORRECT).Value = .Range(G.RNG_TRAIN_CORRECT_COUNT).Value
                DoEvents
            End With
            
        Loop Until sumE / cnt < minLoss

    End With
    
    Call mcHLayer1.SaveWeight(ws_W_H1)
    Call mcHLayer2.SaveWeight(ws_W_H2)
    Call mcOutLayer.SaveWeight(ws_W_Out)
    
    Exit Sub
    
ErrorLabel:
    MsgBox "パラメータが発散しました。", vbOKOnly + vbExclamation

End Sub

Public Sub StartTest()
    Dim r As Long
    Dim c As Long
    Dim eRow As Long
    Dim eCol As Long
    Dim label As String
    Dim t() As Long
    Dim datas() As Double
    Dim ansIndex As Long
    Dim irisName As String
    Dim ansRate As Double

    Call setUnitCount(ws_Test_Data_Input)
    Call makeUnit
    
    Call mcHLayer1.LoadWeight(ws_W_H1)
    Call mcHLayer2.LoadWeight(ws_W_H2)
    Call mcOutLayer.LoadWeight(ws_W_Out)
        
    With ws_Test_Data_Input
    
        eRow = .Cells(Rows.count, 1).End(xlUp).Row
        eCol = .Cells(RW.DATA_TITLE, Columns.count).End(xlToLeft).Column
        
        ReDim datas(eCol - 1)
    
        For r = 2 To eRow
        
            For c = 2 To eCol
                datas(c - 1) = .Cells(r, c).Value
            Next
        
            label = .Cells(r, CL.DATA_LABEL).Value
            t = getT(G.UnitCount_OUT, label)
            
            Call mcHLayer1.Forward(datas)
            Call mcHLayer2.Forward(mcHLayer1.OutputDataList)
            Call mcOutLayer.Forward(mcHLayer2.OutputDataList)

            ansIndex = mcOutLayer.GetAnswerIndex
            ansRate = mcOutLayer.GetAnswerRate(ansIndex)
            
            Call getAnswer(ws_Test_Result, r, ansIndex, ansRate, label)
        
        Next
        
    End With

End Sub

Private Sub getAnswer(ByRef wsResult As Worksheet, ByRef tr As Long, ByRef ansIndex As Long, ByRef ansRate As Double, ByRef label As String)
    Dim irisName As String
    
        Select Case ansIndex
            Case IRIS.SETOSA
                irisName = G.VAL_SETOSA
            Case IRIS.VERSICOLOR
                irisName = G.VAL_VERSICOLOR
            Case IRIS.VIRGINICA
                irisName = G.VAL_VIRGINICA
        End Select
            
    With wsResult
            .Cells(tr, CL.RESULT_LABEL).Value = label
            .Cells(tr, CL.RESULT_ANSWER).Value = irisName
            .Cells(tr, CL.RESULT_RATE).Value = Format(ansRate, "0.0%")
            
            .Cells(tr, CL.RESULT_TF).Value = (irisName = label)
    End With
    
End Sub

Private Function getT(ByRef tCount As Long, ByRef label As String) As Long()
    Dim labels() As Long
    
    ReDim labels(tCount)
    
    Select Case label
        Case G.VAL_SETOSA
            labels(IRIS.SETOSA) = 1
        Case G.VAL_VERSICOLOR
            labels(IRIS.VERSICOLOR) = 1
        Case G.VAL_VIRGINICA
            labels(IRIS.VIRGINICA) = 1
    End Select
    
    getT = labels
    
End Function

Private Sub clearResult()

    With ws_Train_Result
        .Cells.Clear
        .Cells(1, CL.RESULT_LABEL).Value = "ラベル"
        .Cells(1, CL.RESULT_ANSWER).Value = "NNの答え"
        .Cells(1, CL.RESULT_RATE).Value = "自信度"
        .Cells(1, CL.RESULT_TF).Value = "判定"
    End With

    With ws_Test_Result
        .Cells.Clear
        .Cells(1, CL.RESULT_LABEL).Value = "ラベル"
        .Cells(1, CL.RESULT_ANSWER).Value = "NNの答え"
        .Cells(1, CL.RESULT_RATE).Value = "自信度"
        .Cells(1, CL.RESULT_TF).Value = "判定"
    End With
    
    With ws_Main
        .Range(.Columns(CL.LOSS_), .Columns(CL.LOSS_CORRECT)).Clear
    End With
    
End Sub

Private Function getActivationFunction(ByRef arg As String) As Long
    Dim res As Long
    
    Select Case arg
        Case G.VAL_ACT_ReLU
            res = ACT.ReLU
        Case G.VAL_ACT_Softmax
            res = ACT.Softmax
    End Select
    
    getActivationFunction = res
End Function


f:id:celaeno42:20181212233850p:plain