全コードまとめ｜Excel VBAでMNIST機械学習

このページではこれまでに実装したモジュールやレイヤのコードをまとめておきます。
本ページ内のコードをコピペすることでMNIST学習を行うことができ、最終的にはVBAで手書き数字(0〜9)を認識することが可能になります。

1. モジュール作成
2. 実装コードまとめ
3. MNIST学習
4. まとめ

モジュール作成

今回のMNIST学習に使用するモジュールは下記の通りです。
コードをコピペする前に各モジュールを作成しておきましょう。

※画像には「Sigmoid_Layer」がありますが今回のMNIST学習では使用しないため不要です。

実装コードまとめ

上記モジュールのコードは下記の通りです。

csv_Functions (標準モジュール)

Option Explicit
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Function bmp_to_csv() As Long()

    Application.ScreenUpdating = False
    
    Dim FilePath As Variant
    FilePath = Application.GetOpenFilename
    If FilePath = False Then
        End
    End If

    Dim FileSize As Long
    FileSize = FileLen(FilePath)
    If FileSize = 0 Then
        MsgBox "選択したファイルは有効ではありません。"
        Exit Function
    End If

    
    Dim FileID As Integer
    FileID = FreeFile

    Open FilePath For Binary As #FileID

    Dim BinaryData() As Byte
    ReDim BinaryData(0 To FileSize - 1)

    Get #FileID, , BinaryData
    Close #FileID
    
    If Not (BinaryData(0) = 66 And BinaryData(1) = 77) Then
        MsgBox "bmp画像を選択してください。"
        Exit Function
    End If


    'バイナリデータからピクセル値データのみを抜き取る
    
    Dim i As Long
    Dim Data() As Long
    Dim RGBData() As Long
    Dim GrayData() As Long
    
    ReDim Data(UBound(BinaryData) - 53)
    ReDim RGBData(UBound(BinaryData) - 53) 'NNで使うため配列の1番目から値を格納(0番目は空にする)

    For i = 1 To UBound(RGBData)
        RGBData(i) = BinaryData(i + 53)
    Next i
    
    
    'RGBデータをグレースケールデータに変換(学習データと入力値を揃える)
    
    ReDim GrayData(UBound(RGBData) / 3) '0番目は空にする
    
    For i = 1 To UBound(GrayData)
            GrayData(i) = Abs((RGBData((i - 1) * 3 + 1) * 0.11 + _
                               RGBData((i - 1) * 3 + 1 + 1) * 0.59 + _
                               RGBData((i - 1) * 3 + 1 + 2) * 0.3) - 255)
    Next i
    
    Data = AlignBinaryData(GrayData)

    Application.ScreenUpdating = True
    
    bmp_to_csv = Data

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Function AlignBinaryData(ByRef Data() As Long) As Long()

    Dim i As Long
    Dim j As Long
    Dim cnt As Long
    
    Dim out() As Long
    ReDim out(UBound(Data))
    
    cnt = 1
    For i = 28 To 1 Step -1
        For j = 27 To 0 Step -1
            out(cnt) = Data((i * 28) - j)
            cnt = cnt + 1
        Next j
    Next i
    
    AlignBinaryData = out

End Function

Option Explicit

'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――

Function bmp_to_csv() As Long()

Application.ScreenUpdating = False

Dim FilePath As Variant

FilePath = Application.GetOpenFilename

If FilePath = False Then

End

End If

Dim FileSize As Long

FileSize = FileLen(FilePath)

If FileSize = 0 Then

MsgBox "選択したファイルは有効ではありません。"

Exit Function

End If

Dim FileID As Integer

FileID = FreeFile

Open FilePath For Binary As #FileID

Dim BinaryData() As Byte

ReDim BinaryData(0 To FileSize - 1)

Get #FileID, , BinaryData

Close #FileID

If Not (BinaryData(0) = 66 And BinaryData(1) = 77) Then

MsgBox "bmp画像を選択してください。"

Exit Function

End If

'バイナリデータからピクセル値データのみを抜き取る

Dim i As Long

Dim Data() As Long

Dim RGBData() As Long

Dim GrayData() As Long

ReDim Data(UBound(BinaryData) - 53)

ReDim RGBData(UBound(BinaryData) - 53) 'NNで使うため配列の1番目から値を格納(0番目は空にする)

For i = 1 To UBound(RGBData)

RGBData(i) = BinaryData(i + 53)

Next i

'RGBデータをグレースケールデータに変換(学習データと入力値を揃える)

ReDim GrayData(UBound(RGBData) / 3) '0番目は空にする

For i = 1 To UBound(GrayData)

GrayData(i) = Abs((RGBData((i - 1) * 3 + 1) * 0.11 + _

RGBData((i - 1) * 3 + 1 + 1) * 0.59 + _

RGBData((i - 1) * 3 + 1 + 2) * 0.3) - 255)

Next i

Data = AlignBinaryData(GrayData)

Application.ScreenUpdating = True

bmp_to_csv = Data

End Function

Function AlignBinaryData(ByRef Data() As Long) As Long()

Dim i As Long

Dim j As Long

Dim cnt As Long

Dim out() As Long

ReDim out(UBound(Data))

cnt = 1

For i = 28 To 1 Step -1

For j = 27 To 0 Step -1

out(cnt) = Data((i * 28) - j)

cnt = cnt + 1

Next j

Next i

AlignBinaryData = out

End Function

Functions (標準モジュール)

Option Explicit
Option Base 1
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function KeyPress() As Boolean
    Const KEY_PRESSED = -32768
    KeyPress = (GetAsyncKeyState(vbKeyF7) And KEY_PRESSED) = KEY_PRESSED
End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function GetRandomRow(ByRef DataCount As Long, MAX_DATA As Long) As Long()
    Dim i As Long, Num As Long
    Dim flag() As Boolean
    Dim RndRows() As Long
    
    ReDim flag(MAX_DATA)
    ReDim RndRows(MAX_DATA)
    
    For i = 1 To DataCount

        Randomize

        Do
            Num = Int((MAX_DATA - 1 + 1) * Rnd + 1)
        Loop Until flag(Num) = False
        
        RndRows(i) = Num
        flag(Num) = True
    Next i
    
    ReDim Preserve flag(DataCount)
    ReDim Preserve RndRows(DataCount)
    
    GetRandomRow = RndRows
    
End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function RandomWeight(ByRef size1 As Long, ByRef size2 As Long) As Double()

    Dim i As Long
    Dim j As Long
    Dim W As Double
    Dim List() As Double
    
    ReDim List(size1, size2)
    
    For i = 1 To size1
        For j = 1 To size2
    
        Randomize
        
        Do
            W = (Rnd * 2) - 1
        Loop Until W <> 0
    
        List(i, j) = W
        
        Next j
    Next i

    RandomWeight = List

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function zeros(ByRef input_size As Long) As Double()

    Dim i As Long
    Dim ZerosList() As Double
    
    ReDim ZerosList(input_size)

    For i = 1 To input_size
        ZerosList(i) = 0
    Next i
    
    zeros = ZerosList

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function dot(ByRef x() As Double, ByRef W() As Double) As Double()
    
    Dim i As Long
    Dim j As Long
    Dim A() As Double
    
    ReDim A(UBound(W, 2))
    
    Dim sum As Double
    For i = 1 To UBound(W, 2)
        sum = 0
        For j = 1 To UBound(x)
            sum = sum + (x(j) * W(j, i))
        Next j
        A(i) = sum
    Next i
    
    dot = A

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function dot2(ByRef x() As Double, ByRef dout() As Double) As Double()
    
    Dim i As Long
    Dim j As Long
    Dim dW() As Double
    
    ReDim dW(UBound(x), UBound(dout))
    
    For i = 1 To UBound(dout)
        For j = 1 To UBound(x)
            dW(j, i) = x(j) * dout(i)
        Next j
    Next i
    
    dot2 = dW

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function add(ByRef x() As Double, ByRef Bias() As Double) As Double()

    Dim i As Long
    Dim A() As Double
    
    ReDim A(UBound(x))
    
    For i = 1 To UBound(x)
        A(i) = x(i) + Bias(i)
    Next i
    
    add = A
    
End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function softmax(ByRef x() As Double) As Double()

    Dim i As Long
    Dim max As Double
    Dim sum As Double
    Dim z() As Double
    
    ReDim z(UBound(x))

    max = x(1)
    For i = 1 To UBound(x)
        If x(i) > max Then
            max = x(i)
        End If
    Next i

    sum = 0
    For i = 1 To UBound(x)
        sum = sum + Exp(x(i) - max) 'オーバーフロー対策
    Next i
    
    For i = 1 To UBound(x)
        z(i) = Exp(x(i) - max) / sum
    Next i
    
    softmax = z
    
End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function cross_entropy_error(ByRef y() As Double, ByRef t() As Long)

    Dim delta As Double
    delta = 0.0000001 'infを発生させないため微小な数字を加算する
    
    Dim i As Long
    Dim sum As Double

    sum = 0
    For i = 1 To UBound(t)
        sum = sum + (t(i) * Log(y(i) + delta))
    Next

    cross_entropy_error = sum * -1

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function one_hot_t(ByRef t_size As Long, ByRef label As Integer) As Long()
    
    Dim labels() As Long
    
    ReDim labels(t_size)
    
    If label = 0 Then
        labels(10) = 1  '※Option Base 1でlabels(0)が存在しないためlabels(10)を使用
    Else
        labels(label) = 1
    End If
    
    one_hot_t = labels
    
End Function

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

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

Option Explicit

Option Base 1

Public Function KeyPress() As Boolean

Const KEY_PRESSED = -32768

KeyPress = (GetAsyncKeyState(vbKeyF7) And KEY_PRESSED) = KEY_PRESSED

End Function

Public Function GetRandomRow(ByRef DataCount As Long, MAX_DATA As Long) As Long()

Dim i As Long, Num As Long

Dim flag() As Boolean

Dim RndRows() As Long

ReDim flag(MAX_DATA)

ReDim RndRows(MAX_DATA)

For i = 1 To DataCount

Randomize

Num = Int((MAX_DATA - 1 + 1) * Rnd + 1)

Loop Until flag(Num) = False

RndRows(i) = Num

flag(Num) = True

Next i

ReDim Preserve flag(DataCount)

ReDim Preserve RndRows(DataCount)

GetRandomRow = RndRows

End Function

Public Function RandomWeight(ByRef size1 As Long, ByRef size2 As Long) As Double()

Dim i As Long

Dim j As Long

Dim W As Double

Dim List() As Double

ReDim List(size1, size2)

For i = 1 To size1

For j = 1 To size2

Randomize

W = (Rnd * 2) - 1

Loop Until W <> 0

List(i, j) = W

Next j

Next i

RandomWeight = List

End Function

Public Function zeros(ByRef input_size As Long) As Double()

Dim i As Long

Dim ZerosList() As Double

ReDim ZerosList(input_size)

For i = 1 To input_size

ZerosList(i) = 0

Next i

zeros = ZerosList

End Function

Public Function dot(ByRef x() As Double, ByRef W() As Double) As Double()

Dim i As Long

Dim j As Long

Dim A() As Double

ReDim A(UBound(W, 2))

Dim sum As Double

For i = 1 To UBound(W, 2)

sum = 0

For j = 1 To UBound(x)

sum = sum + (x(j) * W(j, i))

Next j

A(i) = sum

Next i

dot = A

End Function

Public Function dot2(ByRef x() As Double, ByRef dout() As Double) As Double()

Dim i As Long

Dim j As Long

Dim dW() As Double

ReDim dW(UBound(x), UBound(dout))

For i = 1 To UBound(dout)

For j = 1 To UBound(x)

dW(j, i) = x(j) * dout(i)

Next j

Next i

dot2 = dW

End Function

Public Function add(ByRef x() As Double, ByRef Bias() As Double) As Double()

Dim i As Long

Dim A() As Double

ReDim A(UBound(x))

For i = 1 To UBound(x)

A(i) = x(i) + Bias(i)

Next i

add = A

End Function

Public Function softmax(ByRef x() As Double) As Double()

Dim i As Long

Dim max As Double

Dim sum As Double

Dim z() As Double

ReDim z(UBound(x))

max = x(1)

For i = 1 To UBound(x)

If x(i) > max Then

max = x(i)

End If

Next i

sum = 0

For i = 1 To UBound(x)

sum = sum + Exp(x(i) - max) 'オーバーフロー対策

Next i

For i = 1 To UBound(x)

z(i) = Exp(x(i) - max) / sum

Next i

softmax = z

End Function

Public Function cross_entropy_error(ByRef y() As Double, ByRef t() As Long)

Dim delta As Double

delta = 0.0000001 'infを発生させないため微小な数字を加算する

Dim i As Long

Dim sum As Double

sum = 0

For i = 1 To UBound(t)

sum = sum + (t(i) * Log(y(i) + delta))

cross_entropy_error = sum * -1

End Function

Public Function one_hot_t(ByRef t_size As Long, ByRef label As Integer) As Long()

Dim labels() As Long

ReDim labels(t_size)

If label = 0 Then

labels(10) = 1 '※Option Base 1でlabels(0)が存在しないためlabels(10)を使用

Else

labels(label) = 1

End If

one_hot_t = labels

End Function

Main (標準モジュール)

Option Explicit
Option Base 1
 
#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
#Else
    Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer
#End If

Dim input_size As Long         '入力層のニューロン数
Dim hidden_size As Long        '隠れ層のニューロン数
Dim output_size As Long        '出力層のニューロン数

Dim MinLoss As Double          '最小Loss値
Dim MaxEpoc As Long            '最大エポック数

Dim LearningRate As Double      '学習率
Dim batch_size As Long          'ミニバッチサイズ

Dim train_size As Long          'mnist_trainの総データ数(default:60000)
Dim test_size As Long           'mnist_testの総データ数(default:10000)

Public ParamsSheet As Worksheet '書き出し用シート

Public ParamsCheck As Boolean   'シート確認用変数
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Sub Train()

'**********************************************************************
'
'        ユーザ－設定(ハイパーパラメータ設定)
'
'**********************************************************************

    
    'ユニット数の設定(Input:784 / Output:10は変更不可)
    
    input_size = 784   '28x28(px)
    hidden_size = 64   '学習結果に応じて変更可
    output_size = 10   '0～9
    
    
    '学習設定
    
    batch_size = 100     'バッチサイズ(Default:100)
    LearningRate = 0.01  '学習率(Default:0.01)
    
    train_size = ws_mnist_train.Cells(Rows.count, 1).End(xlUp).Row   'mnist_trainの総データ数(default:60000)
    test_size = ws_mnist_test.Cells(Rows.count, 1).End(xlUp).Row     'mnist_testの総データ数(default:10000)
    
    
    '学習終了条件
    
    MinLoss = 0.01    '目標Loss値
    MaxEpoc = 500     '最大エポック数(学習回数)


    
    
'**********************************************************************
'
'   　　　　　　 学習開始
'
'**********************************************************************
    
    
'学習途中データの確認-----------------------------------------------------

    ParamsCheck = False  
    
    Dim ws As Worksheet
    Dim flag As Boolean
    Dim res As String
    Dim msg As String
    
    msg = "学習モデルのデータがあります。" & vbLf & _
          "続きから学習を始めますか？" & vbLf & vbLf & _
          "[いいえ]を押すと新規モデルとして学習を始めます。"
    
    
    For Each ws In Worksheets
        If ws.Name = "Parameters" Then flag = True
    Next ws
    
    If flag = True Then
    
        res = MsgBox(msg, vbYesNoCancel + vbInformation, "学習データの再利用")
        
        If res = vbYes Then
            ParamsCheck = True
            Set ParamsSheet = Worksheets.Item("Parameters")
            
        ElseIf res = vbNo Then
            ParamsCheck = False
            flag = False
                  
label1:
            Dim SheetName As String
            SheetName = InputBox("既存のモデル(シート)名を入力して下さい。", "モデル名変更")
            If StrPtr(SheetName) = 0 Then
                MsgBox "キャンセルします。"
                Exit Sub
            ElseIf SheetName = "" Then
                MsgBox "モデル名を入力して下さい。"
                GoTo label1
            End If
            
            For Each ws In Worksheets
                If ws.Name = SheetName Then flag = True
            Next ws
            If flag = True Then
                MsgBox "「" & SheetName & "」は既に存在します。" & vbLf & "別の名称を入力し直してください。"
                GoTo label1
            End If
            
            Worksheets.Item("Parameters").Name = SheetName
            
            Set ParamsSheet = Worksheets.add(After:=Worksheets(1))
            ParamsSheet.Name = "Parameters"
        ElseIf res = vbCancel Then
            MsgBox "キャンセルします。"
            Exit Sub
        End If
        
    Else
    
        Set ParamsSheet = Worksheets.add(After:=Worksheets(1))
        ParamsSheet.Name = "Parameters"
        
    End If

'----------------------------------------------------------------------    
    
    Dim network As TwoLayerNet
    Set network = New TwoLayerNet
    
    'ニューラルネットワークの初期化
    Call network.Initialize(input_size, hidden_size, output_size, ParamsSheet)
    
    
    Dim eRow As Long
    Dim eCol As Long
    Dim Datas() As Double
    Dim c As Long
    Dim r As Long
    Dim i As Long
    Dim epoc As Long
    Dim sumE As Double
    Dim sumAcc As Long
    Dim cnt As Long
    Dim label As Integer
    Dim t() As Long
    
    Dim DataRows() As Long
    
    
    With ws_mnist_train
        
        eRow = .Cells(Rows.count, 1).End(xlUp).Row
        eCol = .Cells(1, Columns.count).End(xlToLeft).Column
            
        ReDim Datas(eCol - 1)
        
        Do
        
            '最大エポック数に到達したら学習終了
            If epoc >= MaxEpoc Then Exit Do
            
            sumAcc = 0
            sumE = 0
            cnt = 0
        
            '学習データ行をランダム取得
            ReDim DataRows(batch_size)
            DataRows = Functions.GetRandomRow(batch_size, train_size)
        
        
            For r = 1 To UBound(DataRows)
                
                cnt = cnt + 1
                
                For c = 2 To eCol
                    Datas(c - 1) = .Cells(DataRows(r), c).Value / 255  '正規化
                Next c
                
                label = .Cells(DataRows(r), 1).Value
                t = Functions.one_hot_t(output_size, label)     'labelをone-hot化
                
                
                Call network.gradient(Datas, t)                 '重み/バイアスパラメータの勾配を求める
                
                sumE = sumE + network.E
                
                If network.accuracy = True Then                
                    sumAcc = sumAcc + 1
                End If
                
                Call network.ParamsUpdate(LearningRate)         'Affinレイヤの重み/バイアスパラメータを更新
                
                
                '[F7]キーが押下されたら学習終了
                If Functions.KeyPress = True Then
                    Call network.ExportParameters(ParamsSheet)
                    MsgBox "学習終了" & vbLf & "学習結果はシート(Parameters)に書き出しました。"
                    Exit Sub
                End If
                
                DoEvents
            Next r
            
            epoc = epoc + 1
            
      'テストデータ(未学習データ)で精度確認-------------------------------------------------------------
            
            Dim testData() As Double
            Dim testLabel As Long
            Dim testDataRows() As Long
            Dim test_acc() As Double
            Dim test_acc_size As Long
            Dim test_cnt As Long
            
            test_acc_size = 100
            ReDim testData(input_size)
            
            ReDim testDataRows(test_acc_size)
            testDataRows = Functions.GetRandomRow(test_acc_size, test_size)
            
            test_cnt = 0
            
            For r = 1 To UBound(testDataRows)
                For c = 2 To eCol
                    testData(c - 1) = ws_mnist_test.Cells(testDataRows(r), c).Value / 255  '正規化
                Next c
                
                testLabel = ws_mnist_test.Cells(testDataRows(r), 1).Value
                
                If network.test_accuracy(testData, testLabel) = True Then
                    test_cnt = test_cnt + 1
                End If
            Next r
            
      '--------------------------------------------------------------------------------------------
            
            '学習の途中経過をイミディエイトウィンドウに表示
            Debug.Print epoc & "回目: " & sumE / cnt & "　正解率: " & (sumAcc / cnt) * 100 & "%  テスト正解率" & (test_cnt / test_acc_size) * 100 & "% "
            
        Loop Until sumE / cnt < MinLoss
    
    End With
 

    '学習済みパラメータを書き出し
    Call network.ExportParameters(ParamsSheet)
        
    MsgBox "学習終了" & vbLf & "学習結果はシート(Parameters)に書き出しました。"

End Sub
'-------------------------------------------------------------------------------
Sub Classification_MNIST()

    input_size = 784   '28x28ピクセル
    hidden_size = 64   '学習結果に応じて変更可(※必ず学習時の構成と揃えること)
    output_size = 10   '0～9

    Dim i As Long
    Dim j As Long
    Dim InputImageData() As Long
    Dim Data() As Double
    
    ReDim InputImageData(input_size)
    ReDim Data(input_size)
    
    InputImageData = csv_Functions.bmp_to_csv
    
    For i = 1 To input_size
        Data(i) = InputImageData(i) / 255
    Next i
    
    Dim ExportSheet As Worksheet
    Set ExportSheet = Worksheets.Item("Sheet1")
    
    ExportSheet.Cells.ClearContents
    Dim cnt As Long
    Application.ScreenUpdating = False
    cnt = 1
    For i = 1 To 28
        For j = 1 To 28
            ExportSheet.Cells(i, j) = InputImageData(cnt)
            cnt = cnt + 1
        Next j
    Next i
    Application.ScreenUpdating = True
    
    Dim ModelSheet As Worksheet
    Set ModelSheet = Worksheets.Item("Parameters_Comp")
    
    Dim network As TwoLayerNet
    Set network = New TwoLayerNet
    

    ParamsCheck = True 'ModelSheetのパラメータを使用する
    
    Call network.Initialize(input_size, hidden_size, output_size, ModelSheet)

    Dim answer As Long
    answer = network.answer(Data)
    
   MsgBox answer

End Sub

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

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

Option Explicit

Option Base 1

#If Win64 Then

Declare PtrSafe Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer

#Else

Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Integer

#End If

Dim input_size As Long '入力層のニューロン数

Dim hidden_size As Long '隠れ層のニューロン数

Dim output_size As Long '出力層のニューロン数

Dim MinLoss As Double '最小Loss値

Dim MaxEpoc As Long '最大エポック数

Dim LearningRate As Double '学習率

Dim batch_size As Long 'ミニバッチサイズ

Dim train_size As Long 'mnist_trainの総データ数(default:60000)

Dim test_size As Long 'mnist_testの総データ数(default:10000)

Public ParamsSheet As Worksheet '書き出し用シート

Public ParamsCheck As Boolean 'シート確認用変数

Sub Train()

'**********************************************************************

' ユーザ－設定(ハイパーパラメータ設定)

'**********************************************************************

'ユニット数の設定(Input:784 / Output:10は変更不可)

input_size = 784 '28x28(px)

hidden_size = 64 '学習結果に応じて変更可

output_size = 10 '0～9

'学習設定

batch_size = 100 'バッチサイズ(Default:100)

LearningRate = 0.01 '学習率(Default:0.01)

train_size = ws_mnist_train.Cells(Rows.count, 1).End(xlUp).Row 'mnist_trainの総データ数(default:60000)

test_size = ws_mnist_test.Cells(Rows.count, 1).End(xlUp).Row 'mnist_testの総データ数(default:10000)

'学習終了条件

MinLoss = 0.01 '目標Loss値

MaxEpoc = 500 '最大エポック数(学習回数)

'**********************************************************************

' 　　　　　　学習開始

'**********************************************************************

'学習途中データの確認-----------------------------------------------------

ParamsCheck = False

Dim ws As Worksheet

Dim flag As Boolean

Dim res As String

Dim msg As String

msg = "学習モデルのデータがあります。" & vbLf & _

"続きから学習を始めますか？" & vbLf & vbLf & _

"[いいえ]を押すと新規モデルとして学習を始めます。"

For Each ws In Worksheets

If ws.Name = "Parameters" Then flag = True

Next ws

If flag = True Then

res = MsgBox(msg, vbYesNoCancel + vbInformation, "学習データの再利用")

If res = vbYes Then

ParamsCheck = True

Set ParamsSheet = Worksheets.Item("Parameters")

ElseIf res = vbNo Then

ParamsCheck = False

flag = False

label1:

Dim SheetName As String

SheetName = InputBox("既存のモデル(シート)名を入力して下さい。", "モデル名変更")

If StrPtr(SheetName) = 0 Then

MsgBox "キャンセルします。"

Exit Sub

ElseIf SheetName = "" Then

MsgBox "モデル名を入力して下さい。"

GoTo label1

End If

For Each ws In Worksheets

If ws.Name = SheetName Then flag = True

Next ws

If flag = True Then

MsgBox "「" & SheetName & "」は既に存在します。" & vbLf & "別の名称を入力し直してください。"

GoTo label1

End If

Worksheets.Item("Parameters").Name = SheetName

Set ParamsSheet = Worksheets.add(After:=Worksheets(1))

ParamsSheet.Name = "Parameters"

ElseIf res = vbCancel Then

MsgBox "キャンセルします。"

Exit Sub

End If

Else

Set ParamsSheet = Worksheets.add(After:=Worksheets(1))

ParamsSheet.Name = "Parameters"

End If

'----------------------------------------------------------------------

Dim network As TwoLayerNet

Set network = New TwoLayerNet

'ニューラルネットワークの初期化

Call network.Initialize(input_size, hidden_size, output_size, ParamsSheet)

Dim eRow As Long

Dim eCol As Long

Dim Datas() As Double

Dim c As Long

Dim r As Long

Dim i As Long

Dim epoc As Long

Dim sumE As Double

Dim sumAcc As Long

Dim cnt As Long

Dim label As Integer

Dim t() As Long

Dim DataRows() As Long

With ws_mnist_train

eRow = .Cells(Rows.count, 1).End(xlUp).Row

eCol = .Cells(1, Columns.count).End(xlToLeft).Column

ReDim Datas(eCol - 1)

'最大エポック数に到達したら学習終了

If epoc >= MaxEpoc Then Exit Do

sumAcc = 0

sumE = 0

cnt = 0

'学習データ行をランダム取得

ReDim DataRows(batch_size)

DataRows = Functions.GetRandomRow(batch_size, train_size)

For r = 1 To UBound(DataRows)

cnt = cnt + 1

For c = 2 To eCol

Datas(c - 1) = .Cells(DataRows(r), c).Value / 255 '正規化

Next c

label = .Cells(DataRows(r), 1).Value

t = Functions.one_hot_t(output_size, label) 'labelをone-hot化

Call network.gradient(Datas, t) '重み/バイアスパラメータの勾配を求める

sumE = sumE + network.E

If network.accuracy = True Then

sumAcc = sumAcc + 1

End If

Call network.ParamsUpdate(LearningRate) 'Affinレイヤの重み/バイアスパラメータを更新

'[F7]キーが押下されたら学習終了

If Functions.KeyPress = True Then

Call network.ExportParameters(ParamsSheet)

MsgBox "学習終了" & vbLf & "学習結果はシート(Parameters)に書き出しました。"

Exit Sub

End If

DoEvents

Next r

epoc = epoc + 1

'テストデータ(未学習データ)で精度確認-------------------------------------------------------------

Dim testData() As Double

Dim testLabel As Long

Dim testDataRows() As Long

Dim test_acc() As Double

Dim test_acc_size As Long

Dim test_cnt As Long

test_acc_size = 100

ReDim testData(input_size)

ReDim testDataRows(test_acc_size)

testDataRows = Functions.GetRandomRow(test_acc_size, test_size)

test_cnt = 0

For r = 1 To UBound(testDataRows)

For c = 2 To eCol

testData(c - 1) = ws_mnist_test.Cells(testDataRows(r), c).Value / 255 '正規化

Next c

testLabel = ws_mnist_test.Cells(testDataRows(r), 1).Value

If network.test_accuracy(testData, testLabel) = True Then

test_cnt = test_cnt + 1

End If

Next r

'--------------------------------------------------------------------------------------------

'学習の途中経過をイミディエイトウィンドウに表示

Debug.Print epoc & "回目: " & sumE / cnt & "　正解率: " & (sumAcc / cnt) * 100 & "% テスト正解率" & (test_cnt / test_acc_size) * 100 & "% "

Loop Until sumE / cnt < MinLoss

End With

'学習済みパラメータを書き出し

Call network.ExportParameters(ParamsSheet)

MsgBox "学習終了" & vbLf & "学習結果はシート(Parameters)に書き出しました。"

End Sub

'-------------------------------------------------------------------------------

Sub Classification_MNIST()

input_size = 784 '28x28ピクセル

hidden_size = 64 '学習結果に応じて変更可(※必ず学習時の構成と揃えること)

output_size = 10 '0～9

Dim i As Long

Dim j As Long

Dim InputImageData() As Long

Dim Data() As Double

ReDim InputImageData(input_size)

ReDim Data(input_size)

InputImageData = csv_Functions.bmp_to_csv

For i = 1 To input_size

Data(i) = InputImageData(i) / 255

Next i

Dim ExportSheet As Worksheet

Set ExportSheet = Worksheets.Item("Sheet1")

ExportSheet.Cells.ClearContents

Dim cnt As Long

Application.ScreenUpdating = False

cnt = 1

For i = 1 To 28

For j = 1 To 28

ExportSheet.Cells(i, j) = InputImageData(cnt)

cnt = cnt + 1

Next j

Next i

Application.ScreenUpdating = True

Dim ModelSheet As Worksheet

Set ModelSheet = Worksheets.Item("Parameters_Comp")

Dim network As TwoLayerNet

Set network = New TwoLayerNet

ParamsCheck = True 'ModelSheetのパラメータを使用する

Call network.Initialize(input_size, hidden_size, output_size, ModelSheet)

Dim answer As Long

answer = network.answer(Data)

MsgBox answer

End Sub

Affine_Layer (クラスモジュール)

Option Explicit
Option Base 1

Dim W() As Double
Dim b() As Double
Dim x() As Double
Dim dW() As Double
Dim db() As Double
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function init(ByRef input_W() As Double, ByRef input_b() As Double)

    Dim i As Long
    Dim j As Long
    
    ReDim W(UBound(input_W, 1), UBound(input_W, 2))
    For i = 1 To UBound(input_W, 1)
        For j = 1 To UBound(input_W, 2)
            W(i, j) = input_W(i, j)
        Next j
    Next i

    ReDim b(UBound(input_b))
    For i = 1 To UBound(input_b)
        b(i) = input_b(i)
    Next i
    
End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function forward(ByRef input_x() As Double) As Double()

    Dim i As Long

    Dim out() As Double
    ReDim x(UBound(input_x))
    ReDim out(UBound(input_x))
    
    For i = 1 To UBound(input_x)
        x(i) = input_x(i)
    Next i
    
    out = Functions.dot(x, W)    '重み付き入力値の総和
    out = Functions.add(out, b)  'バイアス加算
    
    forward = out

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function backward(ByRef dout() As Double)

    Dim i As Long
    Dim j As Long
    Dim WT() As Double
    Dim dx() As Double
    
    ReDim WT(UBound(W, 2), UBound(W, 1))
    For i = 1 To UBound(W, 1)
        For j = 1 To UBound(W, 2)
            WT(j, i) = W(i, j)
        Next j
    Next i
    
    ReDim dx(UBound(W, 1))
    
    dx = Functions.dot(dout, WT)
    
    
    ReDim dW(UBound(W, 1), UBound(W, 2))
    dW = Functions.dot2(x, dout)
    
    
    ReDim db(UBound(W, 2))
    db = dout
    
    backward = dx

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function ParamsUpdate(ByRef LearningRate As Double)

    'Wの更新
    Dim i As Long
    Dim j As Long
    
    For i = 1 To UBound(W, 1)
        For j = 1 To UBound(W, 2)
            W(i, j) = W(i, j) - (LearningRate * dW(i, j))
        Next j
    Next i

    'bの更新
    For i = 1 To UBound(b)
        b(i) = b(i) - (LearningRate * db(i))
    Next i

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Property Get Weight()

    Weight = W

End Property
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Property Get Bias()

    Bias = b

End Property

100

101

102

103

104

105

106

107

Option Explicit

Option Base 1

Dim W() As Double

Dim b() As Double

Dim x() As Double

Dim dW() As Double

Dim db() As Double

Public Function init(ByRef input_W() As Double, ByRef input_b() As Double)

Dim i As Long

Dim j As Long

ReDim W(UBound(input_W, 1), UBound(input_W, 2))

For i = 1 To UBound(input_W, 1)

For j = 1 To UBound(input_W, 2)

W(i, j) = input_W(i, j)

Next j

Next i

ReDim b(UBound(input_b))

For i = 1 To UBound(input_b)

b(i) = input_b(i)

Next i

End Function

Public Function forward(ByRef input_x() As Double) As Double()

Dim i As Long

Dim out() As Double

ReDim x(UBound(input_x))

ReDim out(UBound(input_x))

For i = 1 To UBound(input_x)

x(i) = input_x(i)

Next i

out = Functions.dot(x, W) '重み付き入力値の総和

out = Functions.add(out, b) 'バイアス加算

forward = out

End Function

Public Function backward(ByRef dout() As Double)

Dim i As Long

Dim j As Long

Dim WT() As Double

Dim dx() As Double

ReDim WT(UBound(W, 2), UBound(W, 1))

For i = 1 To UBound(W, 1)

For j = 1 To UBound(W, 2)

WT(j, i) = W(i, j)

Next j

Next i

ReDim dx(UBound(W, 1))

dx = Functions.dot(dout, WT)

ReDim dW(UBound(W, 1), UBound(W, 2))

dW = Functions.dot2(x, dout)

ReDim db(UBound(W, 2))

db = dout

backward = dx

End Function

Public Function ParamsUpdate(ByRef LearningRate As Double)

'Wの更新

Dim i As Long

Dim j As Long

For i = 1 To UBound(W, 1)

For j = 1 To UBound(W, 2)

W(i, j) = W(i, j) - (LearningRate * dW(i, j))

Next j

Next i

'bの更新

For i = 1 To UBound(b)

b(i) = b(i) - (LearningRate * db(i))

Next i

End Function

Public Property Get Weight()

Weight = W

End Property

Public Property Get Bias()

Bias = b

End Property

ReLU_Layer (クラスモジュール)

Option Explicit
Option Base 1

Dim mask() As Boolean
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function forward(ByRef x() As Double) As Double()

    Dim i As Long
    Dim out() As Double
    
    ReDim out(UBound(x))
    ReDim mask(UBound(x))
    
    For i = 1 To UBound(x)
        
        If x(i) <= 0 Then
            out(i) = 0
            mask(i) = True
        Else
            out(i) = x(i)
            mask(i) = False
        End If
        
    Next i
    
    forward = out

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function backward(ByRef dout() As Double) As Double()

    Dim i As Long
    Dim dx() As Double
    
    ReDim dx(UBound(dout))
    
    For i = 1 To UBound(dout)
        
        If mask(i) = True Then
            dx(i) = 0
        Else
            dx(i) = dout(i)
        End If
        
    Next i
    
    backward = dx

End Function

Option Explicit

Option Base 1

Dim mask() As Boolean

Public Function forward(ByRef x() As Double) As Double()

Dim i As Long

Dim out() As Double

ReDim out(UBound(x))

ReDim mask(UBound(x))

For i = 1 To UBound(x)

If x(i) <= 0 Then

out(i) = 0

mask(i) = True

Else

out(i) = x(i)

mask(i) = False

End If

Next i

forward = out

End Function

Public Function backward(ByRef dout() As Double) As Double()

Dim i As Long

Dim dx() As Double

ReDim dx(UBound(dout))

For i = 1 To UBound(dout)

If mask(i) = True Then

dx(i) = 0

Else

dx(i) = dout(i)

End If

Next i

backward = dx

End Function

SoftmaxWithLoss_Layer (クラスモジュール)

Option Explicit
Option Base 1

Dim loss As Double
Dim y() As Double
Dim t() As Long
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function forward(ByRef x() As Double, ByRef input_t() As Long) As Double
    
    Dim i As Long
    
    ReDim t(UBound(input_t))
    For i = 1 To UBound(input_t)
        t(i) = input_t(i)
    Next i
    
    ReDim y(UBound(x))
    y = Functions.softmax(x)
    
    loss = Functions.cross_entropy_error(y, t)
    
    forward = loss

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function backward(ByRef dout As Double) As Double()

    Dim dx() As Double
    Dim i As Long
    
    ReDim dx(UBound(t))
    
    For i = 1 To UBound(t)
        dx(i) = (y(i) - t(i))
    Next
    
    backward = dx
    
End Function

Option Explicit

Option Base 1

Dim loss As Double

Dim y() As Double

Dim t() As Long

Public Function forward(ByRef x() As Double, ByRef input_t() As Long) As Double

Dim i As Long

ReDim t(UBound(input_t))

For i = 1 To UBound(input_t)

t(i) = input_t(i)

Next i

ReDim y(UBound(x))

y = Functions.softmax(x)

loss = Functions.cross_entropy_error(y, t)

forward = loss

End Function

Public Function backward(ByRef dout As Double) As Double()

Dim dx() As Double

Dim i As Long

ReDim dx(UBound(t))

For i = 1 To UBound(t)

dx(i) = (y(i) - t(i))

backward = dx

End Function

TwoLayerNet (クラスモジュール)

Option Explicit
Option Base 1

Dim Affine1 As Affine_Layer
Dim ReLU As ReLU_Layer
Dim Affine2 As Affine_Layer
Dim SoftmaxWithLoss As SoftmaxWithLoss_Layer

Dim class_loss As Double
Dim class_accuracy As Boolean

Dim class_input_size As Long    '入力層ニューロン数
Dim class_hidden_size As Long   '隠れ層ニューロン数
Dim class_output_size As Long   '出力層ニューロン数
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Sub Initialize(ByRef input_size As Long, ByRef hidden_size As Long, ByRef output_size As Long, ByRef Sheet As Worksheet)

    Dim WeightList1() As Double
    Dim WeightList2() As Double
    Dim BiasList1() As Double
    Dim BiasList2() As Double

    ReDim WeightList1(input_size, hidden_size) 'W1
    ReDim WeightList2(hidden_size, output_size) 'W2
    ReDim BiasList1(hidden_size)   'b1
    ReDim BiasList2(output_size)   'b2
    
    class_input_size = input_size
    class_hidden_size = hidden_size
    class_output_size = output_size

    Dim i As Long
    Dim j As Long

    '**************************************************
    '           W1,b1の作成と初期化(読み込み)
    '**************************************************
    
    If ParamsCheck = False Then

        WeightList1 = Functions.RandomWeight(input_size, hidden_size) '引数の数だけランダムの重みを作成してリストに格納
        BiasList1 = Functions.zeros(hidden_size)
        
    Else
        For i = 1 To UBound(WeightList1, 1)
            For j = 1 To UBound(WeightList1, 2)
                WeightList1(i, j) = Sheet.Cells(i, j)
            Next j
        Next i
        
        For i = 1 To UBound(BiasList1)
            BiasList1(i) = Sheet.Cells(UBound(WeightList1, 1) + 1, i)
        Next i
    End If


    '**************************************************
    '           W2,b2の作成と初期化(読み込み)
    '**************************************************
    
    If ParamsCheck = False Then

        WeightList2 = Functions.RandomWeight(hidden_size, output_size) '引数の数だけランダムの重みを作成してリストに格納
        BiasList2 = Functions.zeros(output_size)
        
    Else
        For i = 1 To UBound(WeightList2, 1)
            For j = 1 To UBound(WeightList2, 2)
                WeightList2(i, j) = Sheet.Cells(UBound(WeightList1, 1) + 1 + i, j)
            Next j
        Next i
        
        For i = 1 To UBound(BiasList2)
            BiasList2(i) = Sheet.Cells(UBound(WeightList1, 1) + 1 + UBound(WeightList2, 1) + 1, i)
        Next i
    End If

    
    '**************************************************
    '            　 レイヤの生成
    '**************************************************

    Set Affine1 = New Affine_Layer
    Call Affine1.init(WeightList1, BiasList1)
    
    Set ReLU = New ReLU_Layer

    Set Affine2 = New Affine_Layer
    Call Affine2.init(WeightList2, BiasList2)

    Set SoftmaxWithLoss = New SoftmaxWithLoss_Layer

End Sub
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function predict(ByRef x() As Double) As Double()

    Dim a1() As Double '活性化前重み付き入力値の総和(input→hidden)
    Dim a2() As Double '活性化前重み付き入力値の総和(hidden→output)
    Dim z1() As Double 'a1の活性化後の値(ReLU関数)


    a1 = Affine1.forward(x)
    z1 = ReLU.forward(a1)
    a2 = Affine2.forward(z1)
    
    predict = a2    'Softmax前までの入力値の総和
    
End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function loss(ByRef x() As Double, ByRef t() As Long)

    Dim i As Integer
    Dim max_t_index As Integer
    Dim max_y As Double
    Dim max_y_index As Integer
    Dim y() As Double
    
    ReDim y(class_output_size)
    
    y = predict(x)
    
    class_loss = SoftmaxWithLoss.forward(y, t)
    
    loss = class_loss


    't(正解ラベル)が「1」のインデックスを取得
    For i = 1 To UBound(t)
        If t(i) = 1 Then
            max_t_index = i
        End If
    Next i

    'y(softmax出力値)が最大値のインデックスを取得

    max_y = y(1)
    max_y_index = 1
    For i = 1 To UBound(y)
        If y(i) > max_y Then
            max_y = y(i)
            max_y_index = i
        End If
    Next i

    If max_t_index = max_y_index Then
        class_accuracy = True
    Else
        class_accuracy = False
    End If

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Property Get E()

    E = class_loss

End Property
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Property Get accuracy() As Boolean

    accuracy = class_accuracy
    
End Property
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function gradient(ByRef x() As Double, ByRef t() As Long)

    'forward
    Call loss(x, t)
    
    'backward
    Dim dout As Double
    Dim dx() As Double
    
    dout = 1
    ReDim dx(UBound(t))

    dx = SoftmaxWithLoss.backward(dout)
    
    Dim da2() As Double 'output→hiddenの逆伝播の値
    Dim dz1() As Double 'ReLU関数の逆伝播の値
    Dim da1() As Double 'hidden→inputの逆伝播の値

    da2 = Affine2.backward(dx)
    dz1 = ReLU.backward(da2)
    da1 = Affine1.backward(dz1)

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function ParamsUpdate(ByRef LearningRate As Double)

    Call Affine1.ParamsUpdate(LearningRate)
    Call Affine2.ParamsUpdate(LearningRate)

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function ExportParameters(ByRef ExportSheet As Worksheet)

    Application.ScreenUpdating = False

    Dim i As Long
    Dim j As Long

    Dim W1() As Double
    Dim b1() As Double
    Dim W2() As Double
    Dim b2() As Double
    
    ReDim W1(class_input_size, class_hidden_size)
    ReDim b1(class_hidden_size)
    ReDim W2(class_hidden_size, class_output_size)
    ReDim b2(class_output_size)

    W1 = Affine1.Weight
    b1 = Affine1.Bias
    W2 = Affine2.Weight
    b2 = Affine2.Bias
    
    With ExportSheet
    
        .Cells.ClearContents
    
        For i = 1 To UBound(W1, 1) '784
            For j = 1 To UBound(W1, 2)
                .Cells(i, j).Value = W1(i, j)
            Next j
        Next i

        For i = 1 To UBound(b1)
            .Cells(UBound(W1, 1) + 1, i).Value = b1(i)
        Next i

        For i = 1 To UBound(W2, 1)
            For j = 1 To UBound(W2, 2)
                .Cells(UBound(W1, 1) + 1 + i, j).Value = W2(i, j)
            Next j
        Next i

        For i = 1 To UBound(b2)
            .Cells(UBound(W1, 1) + 1 + UBound(W2, 1) + 1, i).Value = b2(i)
        Next i

    
    End With
    
    Application.ScreenUpdating = True

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function test_accuracy(ByRef x() As Double, ByRef t As Long) As Boolean

    Dim i As Long
    Dim ans As Long
    Dim ans2 As Long
    Dim tmp_a As Double
    Dim tmp_t As Long
    Dim A() As Double
    
    ReDim A(10)

    A = predict(x)
    
    tmp_a = A(1)
    ans = 1
    For i = 1 To UBound(A)
        If tmp_a < A(i) Then
            tmp_a = A(i)
            ans = i
        End If
    Next i
    
    If ans = 10 Then
        ans = 0
    End If

    If ans = t Then
        test_accuracy = True
    Else
        test_accuracy = False
    End If

End Function
'――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Public Function answer(ByRef x() As Double) As Long

    Dim i As Long
    Dim ans As Long
    Dim tmp_a As Double
    Dim A() As Double

    ReDim A(class_output_size)

    A = predict(x)

    tmp_a = A(1)
    ans = 1
    For i = 1 To UBound(A)
        If tmp_a < A(i) Then
            tmp_a = A(i)
            ans = i
        End If
    Next i

    If ans = 10 Then
        ans = 0
    End If

    answer = ans

End Function

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

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

Option Explicit

Option Base 1

Dim Affine1 As Affine_Layer

Dim ReLU As ReLU_Layer

Dim Affine2 As Affine_Layer

Dim SoftmaxWithLoss As SoftmaxWithLoss_Layer

Dim class_loss As Double

Dim class_accuracy As Boolean

Dim class_input_size As Long '入力層ニューロン数

Dim class_hidden_size As Long '隠れ層ニューロン数

Dim class_output_size As Long '出力層ニューロン数

Public Sub Initialize(ByRef input_size As Long, ByRef hidden_size As Long, ByRef output_size As Long, ByRef Sheet As Worksheet)

Dim WeightList1() As Double

Dim WeightList2() As Double

Dim BiasList1() As Double

Dim BiasList2() As Double

ReDim WeightList1(input_size, hidden_size) 'W1

ReDim WeightList2(hidden_size, output_size) 'W2

ReDim BiasList1(hidden_size) 'b1

ReDim BiasList2(output_size) 'b2

class_input_size = input_size

class_hidden_size = hidden_size

class_output_size = output_size

Dim i As Long

Dim j As Long

'**************************************************

' W1,b1の作成と初期化(読み込み)

'**************************************************

If ParamsCheck = False Then

WeightList1 = Functions.RandomWeight(input_size, hidden_size) '引数の数だけランダムの重みを作成してリストに格納

BiasList1 = Functions.zeros(hidden_size)

Else

For i = 1 To UBound(WeightList1, 1)

For j = 1 To UBound(WeightList1, 2)

WeightList1(i, j) = Sheet.Cells(i, j)

Next j

Next i

For i = 1 To UBound(BiasList1)

BiasList1(i) = Sheet.Cells(UBound(WeightList1, 1) + 1, i)

Next i

End If

'**************************************************

' W2,b2の作成と初期化(読み込み)

'**************************************************

If ParamsCheck = False Then

WeightList2 = Functions.RandomWeight(hidden_size, output_size) '引数の数だけランダムの重みを作成してリストに格納

BiasList2 = Functions.zeros(output_size)

Else

For i = 1 To UBound(WeightList2, 1)

For j = 1 To UBound(WeightList2, 2)

WeightList2(i, j) = Sheet.Cells(UBound(WeightList1, 1) + 1 + i, j)

Next j

Next i

For i = 1 To UBound(BiasList2)

BiasList2(i) = Sheet.Cells(UBound(WeightList1, 1) + 1 + UBound(WeightList2, 1) + 1, i)

Next i

End If

'**************************************************

' 　レイヤの生成

'**************************************************

Set Affine1 = New Affine_Layer

Call Affine1.init(WeightList1, BiasList1)

Set ReLU = New ReLU_Layer

Set Affine2 = New Affine_Layer

Call Affine2.init(WeightList2, BiasList2)

Set SoftmaxWithLoss = New SoftmaxWithLoss_Layer

End Sub

Public Function predict(ByRef x() As Double) As Double()

Dim a1() As Double '活性化前重み付き入力値の総和(input→hidden)

Dim a2() As Double '活性化前重み付き入力値の総和(hidden→output)

Dim z1() As Double 'a1の活性化後の値(ReLU関数)

a1 = Affine1.forward(x)

z1 = ReLU.forward(a1)

a2 = Affine2.forward(z1)

predict = a2 'Softmax前までの入力値の総和

End Function

Public Function loss(ByRef x() As Double, ByRef t() As Long)

Dim i As Integer

Dim max_t_index As Integer

Dim max_y As Double

Dim max_y_index As Integer

Dim y() As Double

ReDim y(class_output_size)

y = predict(x)

class_loss = SoftmaxWithLoss.forward(y, t)

loss = class_loss

't(正解ラベル)が「1」のインデックスを取得

For i = 1 To UBound(t)

If t(i) = 1 Then

max_t_index = i

End If

Next i

'y(softmax出力値)が最大値のインデックスを取得

max_y = y(1)

max_y_index = 1

For i = 1 To UBound(y)

If y(i) > max_y Then

max_y = y(i)

max_y_index = i

End If

Next i

If max_t_index = max_y_index Then

class_accuracy = True

Else

class_accuracy = False

End If

End Function

Public Property Get E()

E = class_loss

End Property

Public Property Get accuracy() As Boolean

accuracy = class_accuracy

End Property

Public Function gradient(ByRef x() As Double, ByRef t() As Long)

'forward

Call loss(x, t)

'backward

Dim dout As Double

Dim dx() As Double

dout = 1

ReDim dx(UBound(t))

dx = SoftmaxWithLoss.backward(dout)

Dim da2() As Double 'output→hiddenの逆伝播の値

Dim dz1() As Double 'ReLU関数の逆伝播の値

Dim da1() As Double 'hidden→inputの逆伝播の値

da2 = Affine2.backward(dx)

dz1 = ReLU.backward(da2)

da1 = Affine1.backward(dz1)

End Function

Public Function ParamsUpdate(ByRef LearningRate As Double)

Call Affine1.ParamsUpdate(LearningRate)

Call Affine2.ParamsUpdate(LearningRate)

End Function

Public Function ExportParameters(ByRef ExportSheet As Worksheet)

Application.ScreenUpdating = False

Dim i As Long

Dim j As Long

Dim W1() As Double

Dim b1() As Double

Dim W2() As Double

Dim b2() As Double

ReDim W1(class_input_size, class_hidden_size)

ReDim b1(class_hidden_size)

ReDim W2(class_hidden_size, class_output_size)

ReDim b2(class_output_size)

W1 = Affine1.Weight

b1 = Affine1.Bias

W2 = Affine2.Weight

b2 = Affine2.Bias

With ExportSheet

.Cells.ClearContents

For i = 1 To UBound(W1, 1) '784

For j = 1 To UBound(W1, 2)

.Cells(i, j).Value = W1(i, j)

Next j

Next i

For i = 1 To UBound(b1)

.Cells(UBound(W1, 1) + 1, i).Value = b1(i)

Next i

For i = 1 To UBound(W2, 1)

For j = 1 To UBound(W2, 2)

.Cells(UBound(W1, 1) + 1 + i, j).Value = W2(i, j)

Next j

Next i

For i = 1 To UBound(b2)

.Cells(UBound(W1, 1) + 1 + UBound(W2, 1) + 1, i).Value = b2(i)

Next i

End With

Application.ScreenUpdating = True

End Function

Public Function test_accuracy(ByRef x() As Double, ByRef t As Long) As Boolean

Dim i As Long

Dim ans As Long

Dim ans2 As Long

Dim tmp_a As Double

Dim tmp_t As Long

Dim A() As Double

ReDim A(10)

A = predict(x)

tmp_a = A(1)

ans = 1

For i = 1 To UBound(A)

If tmp_a < A(i) Then

tmp_a = A(i)

ans = i

End If

Next i

If ans = 10 Then

ans = 0

End If

If ans = t Then

test_accuracy = True

Else

test_accuracy = False

End If

End Function

Public Function answer(ByRef x() As Double) As Long

Dim i As Long

Dim ans As Long

Dim tmp_a As Double

Dim A() As Double

ReDim A(class_output_size)

A = predict(x)

tmp_a = A(1)

ans = 1

For i = 1 To UBound(A)

If tmp_a < A(i) Then

tmp_a = A(i)

ans = i

End If

Next i

If ans = 10 Then

ans = 0

End If

answer = ans

End Function

MNIST学習

上記コードをコピペしたら下記の手順を行うことで手書き文字が認識できるようになります。

1. MNISTデータセットを学習させてみよう　　ニューラルネットワークの学習
2. 手書き文字の認識をさせてみよう　　　　　ニューラルネットワークによる推論

まとめ

このページでは「Excel VBAでニューラルネットワークを再現｜MNIST学習で文字認識」で実装したモジュールのVBAコードをまとめて紹介しました。コードで何を行なっているのか詳しく知りたい方は下記リンクを参照してください。

created by Rinker

2021年1月3日2021年1月5日AI, Deep Learning, Excel, VBA

Posted by Lic

Irisデータセットのダウンロード | Excel VBAでIris分類問題

CATDrawingをDXF/PDFファイルで出力｜CATIAマクロの作成方法

全コードまとめ｜Excel VBAでMNIST機械学習

モジュール作成

実装コードまとめ

csv_Functions (標準モジュール)

Functions (標準モジュール)

Main (標準モジュール)

Affine_Layer (クラスモジュール)

ReLU_Layer (クラスモジュール)

SoftmaxWithLoss_Layer (クラスモジュール)

TwoLayerNet (クラスモジュール)

MNIST学習

まとめ

標準モジュール

クラスモジュール

icon-book 参考書籍

参考書籍