無限不可能性ドライブ

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

(お題)式を解析して導関数を求める

面白そうなお題があったので挑戦。


Option Explicit

Public Sub Main()
    Dim y As String
    Dim y2 As String
    Dim y_prime As String
    Dim prime As String
    Dim pos As Long
    Dim i As Long
    Dim char As String
    Dim buf As String
    
    y = "y = 5x^3 + 2x^2 + 7x + 5"
    y = Replace(y, " ", "")                 '空白除去(y=5x^3+2x^2+7x+5)
    
    pos = InStr(y, "=")
    y_prime = Left(y, pos)                  'y=
    y2 = Mid(y, pos + 1)                    '5x^3+2x^2+7x+5

    For i = 1 To Len(y2)
        char = Mid(y2, i, 1)
        If char = "+" Or char = "-" Then
            y_prime = y_prime & getPrime(buf) & char
            buf = ""
        Else
            buf = buf & char
        End If
    Next
    
    y_prime = y_prime & getPrime(buf)
    
    If Right(y_prime, 1) = "+" Or Right(y_prime, 1) = "-" Then
        y_prime = Left(y_prime, Len(y_prime) - 1)
    End If
    
    Debug.Print y_prime                 'y=15x^2+4x+7

End Sub

Private Function getPrime(ByRef aFormula As String) As String
    Dim pos As Long
    Dim x As String
    Dim exponent As Long
    
    pos = InStr(aFormula, "^")
    
    If pos > 0 Then
        x = Left(aFormula, pos - 1)
        exponent = Val(Mid(aFormula, pos + 1))
        getPrime = exponent * Val(x) & "x"
        If exponent > 2 Then
             getPrime = getPrime & "^" & (exponent - 1)
        End If
    Else
        If InStr(aFormula, "x") > 0 Then
            getPrime = Val(aFormula)
        Else
            getPrime = ""
        End If
    End If
    
End Function

ちゃんとテストしてないけどお題はクリアできたからいいかな。

f:id:celaeno42:20181212233850p:plain

【VBA】文字を隠したいならセルの色に埋め込んじゃえばいいじゃない…

!!ノンプロ研企画アドベントカレンダー!!

こちらは私が所属しているコミュニティ「ノンプログラマーのためのスキルアップ研究会」通称「ノンプロ研」の年末特別企画、ノンプロ研 Advent Calendar 2019 の17日目の記事として投稿しています。
adventar.org

なんて書いてあるの?

突然ですが、この色のついたセル、ここになんて書いてあるかわかるでしょうか…
勘のいいひとならわかりますよね?え?わかる?ほんとにわかるの?マジで!?

f:id:celaeno42:20191029201501p:plain:w500

いや、まぁ、一般的にはわかりませんよね。

でも、これをある方法で変換すると文字列がでてきます。

「The quick brown fox jumps over the lazy dog.」

今回はこの方法について説明していきます。

たねあかし

たねあかしをすると簡単です。

f:id:celaeno42:20191029203750p:plain:w500

文字コードアスキーコード)を2倍してRGBのそれぞれにあてていたんですね。2倍にしているのは、そのままだと色が暗くなってしまうからです。主要な文字のアスキーコードは 127 までで、2倍しても 254 となり色の範囲の 0 ~ 255 に収まるので大丈夫です。もし暗い色味の方がお好みの方は2倍にしなくてもいいです。

実装

やり方がわかったので実装してみましょう!
今回は標準モジュールに書いていきます。

【シートと標準モジュールの準備】

シートのオブジェクト名を変更し標準モジュールを追加しましょう。

f:id:celaeno42:20191119195348p:plain

オブジェクト オブジェクト名
Sheet1 wsMain
標準モジュール mdlMain

ついでに、Sheet1のA1セルに「埋め込む文字列:」、A2セルに「抽出した文字列:」と書いておきます。
また、セルの幅と高さは42ピクセルにしていますが、このサイズはお好みで。

f:id:celaeno42:20191119200044p:plain

【定数の宣言、シートの準備】

定数も宣言しておきましょう。

定数名 意味
RNG_TEXT 埋め込む文字列を記入するセル
RNG_DECODE_TEXT 抽出した文字列を表示するセル
RW.CLR_START 色を付けるセルの開始列
CL.CLR_START 色を付けるセルの開始行
Const RNG_TEXT As String = "D1"
Const RNG_DECODE_TEXT As String = "D2"

Enum RW
    CLR_START = 6
End Enum

Enum CL
    CLR_START = 5
End Enum

【埋め込み処理】

文字列を1文字ずつアスキーコードに変換して色として設定していきます。
RGBそれぞれに1文字を割り当てているので、3文字で1カラーになります。

Public Sub Click_埋め込む()
    Dim strText As String
    Dim strChar As String
    Dim clrR As Long, clrG As Long, clrB As Long
    Dim clrNum As Long
    Dim i As Long
    Dim r As Long
    Dim c As Long
    Dim flag As Boolean
    
    With wsMain
    
        '初期化
        .Cells.Interior.ColorIndex = xlNone
        .Range(RNG_DECODE_TEXT).ClearContents
        
        '埋め込む文字列を取得
        strText = .Range(RNG_TEXT).Value
        
        r = RW.CLR_START
        c = CL.CLR_START - 1
        
        '文字列の長さまで繰り返す
        For i = 1 To Len(strText)
        
            '[ 1 ] 文字を一文字取り出して、アスキーコードに変換して2倍する
            strChar = Mid(strText, i, 1)
            clrNum = Asc(strChar) * 2
            
            flag = False
            Select Case i Mod 3
                Case 1          '[ 2 ] G,B を初期化し、R(赤)を設定、色を付けるセルの行、列を更新
                    clrG = 255
                    clrB = 255
                    
                    clrR = clrNum
                    
                    c = c + 1
                    If c > 10 Then
                        r = r + 1
                        c = CL.CLR_START
                    End If
                
                Case 2          '[ 3 ] G(緑)を設定
                    clrG = clrNum
                
                Case Else      '[ 4 ] B(青)を設定し、セルに色を付ける
                    clrB = clrNum
                    .Cells(r, c).Interior.Color = RGB(clrR, clrG, clrB)
                    flag = True
                    
            End Select
            
        Next
        
        '[ 5 ] 文字数の関係でBまで設定できなかった場合、セルに着色されていないのでここで着色する
        If Not flag Then
            .Cells(r, c).Interior.Color = RGB(clrR, clrG, clrB)
        End If
        
    End With

End Sub

コードの解説

コードのポイントについて解説します。

[ 1 ] 文字を一文字取り出して、アスキーコードに変換して2倍する

For文でぐるぐる回しながら1文字ずつ取得していきます。文字を取得したら Asc() でアスキーコードに変換します。今回は色を明るくしたいので2倍しています。

[ 2 ] G,B を初期化し、R(赤)を設定、色を付けるセルの行、列を更新

対象とする文字の位置を3で割った余りが1の場合、つまり、1文字目、4文字目、7文字目…の処理です。[ 1 ] で得られたアスキーコードを R (赤)の色の値として変数に格納します。

RGBそれぞれが1文字に対応しているため、文字数によってはキリが悪くなることがあります(文字数が3で割り切れない場合)。その場合、GとBを初期化しておかないと前の色の値が残ったままになってしまうため、意図しない文字が埋め込まれてしまうことになります。今回は、初期値として 255 を設定し、値が 255 だった場合は文字を出力しないという設計にしています。

また、色を塗りたいセルの場所を更新しています。今回は横に10セル塗ったら行を変えるようにしていますが、この辺りはお好みで。

[ 3 ] G(緑)を設定

対象とする文字の位置を3で割った余りが2の場合、つまり、2文字目、5文字目、8文字目…の処理です。[ 1 ] で得られたアスキーコードを G (緑)の色の値として変数に格納します。

[ 4 ] B(青)を設定し、セルに色を付ける

対象とする文字の位置が3で割り切れる場合、つまり、3文字目、6文字目、9文字目…の処理です。[ 1 ] で得られたアスキーコードを B (青)の色の値として変数に格納します。

ここに到達した場合は R と G には色の値が格納されているので、セルに色を付けます。
flag は文字数の関係でここまで到達しなかった場合(R か G までで For を抜けた場合)に処理の最後で別途色を付ける必要があるため、その目安とするフラグです。

[ 5 ] 文字数の関係でBまで設定できなかった場合、セルに着色されていないのでここで着色する

flag が False の場合は、B まで到達せずに For を抜けた(着色されていない)ということを意味するので、ここで着色します。

【抽出処理】

さて、セルの色に文字を埋め込めたので、今度は抽出(復元)です。
セルの色情報から埋め込んだ文字列を抽出します。
セルの色を R, G, B に分解してそれぞれを1文字として変換すればOKです。

Public Sub Click_抽出する()
    Dim r As Long
    Dim c As Long
    Dim strText As String
    Dim clrNum As Long
    Dim hexR As String, hexG As String, hexB As String
    Dim lngR As Long, lngG As Long, lngB As Long
    Dim chrR As String, chrG As String, chrB As String
    
    With wsMain
        
        strText = ""
        r = RW.CLR_START
        c = CL.CLR_START
        '未着色セルが出現するまで繰り返す
        Do
            Do
                '[ 1 ] セルの色を取得し、16進数でRGBに変換する
                clrNum = .Cells(r, c).Interior.Color
                hexR = "&H" & Right(Hex(clrNum), 2)
                hexG = "&H" & Mid(Hex(clrNum), 3, 2)
                hexB = "&H" & Left(Hex(clrNum), 2)
                
                '[ 2 ] 16進数を10進数に変換する
                lngR = CLng(hexR)
                lngG = CLng(hexG)
                lngB = CLng(hexB)
                
                '[ 3 ] 色の値が255でなかったら2で割って文字に変換する
                If lngR <> 255 Then
                    lngR = lngR / 2
                    strText = strText & Chr(lngR)
                End If
                
                If lngG <> 255 Then
                    lngG = lngG / 2
                    strText = strText & Chr(lngG)
                End If
                
                If lngB <> 255 Then
                    lngB = lngB / 2
                    strText = strText & Chr(lngB)
                End If
                
                c = c + 1
            Loop Until .Cells(r, c).Interior.ColorIndex = xlNone
            r = r + 1
            c = CL.CLR_START
        Loop Until .Cells(r, c).Interior.ColorIndex = xlNone
        
        '[ 4 ] 取得した文字列を表示する
        .Range(RNG_DECODE_TEXT).Value = strText
        
    End With
    
End Sub

コードの解説

コードのポイントについて解説します。

[ 1 ] セルの色を取得し、16進数でRGBに変換する

Do - Loop でぐるぐる繰り返しながら1セルずつ処理していきます。

clrNum にセルの色を格納します。RGBに分解しやすいように、一度16進数に変換してから、右側2文字(R)、真ん中2文字(G)、左側2文字(B)に分け、「&H」を付加することで16進数に戻しています。
※ 取得された色の16進表記は「BGR」の順になっているので注意してください。(「RGB」の順ではないです。)

例えば、1つめのセルの色は10進数で「13291688」ですが、これを16進数に変換すると「CAD0A8」となります。
右側の2文字「A8」を取り出し文字列「&HA8」として、hexR に格納します。hexG、hexB も同様です。

[ 2 ] 16進数(文字列)を10進数に変換する

[ 1 ] で hexR、hexG、hexB に格納された文字列は「&H○○」の形式なので、16進数とみなすことができます。そこで、それぞれを CLng() を使って 10進数に変換します。
例えば、上で hexR に格納されているのは「&HA8」ですが、これを10進数に変換すると「168」になります。
同様に、hexG に格納されているのは「&HD0」なので「208」、hexB は「&HCA」なので「202」となります。

[ 3 ] 色の値が255でなかったら2で割って文字に変換する

さて、埋め込み処理の際に 255 にした場合は文字として出力しないことにするとしていたので、[ 2 ] で変換された数値が 255 でない場合のみ処理を行います。今回は、元の文字のアスキーコードを 2倍にして埋め込んでいるので、ここでは 2で割って元のアスキーコードに戻しています(lngR = lngR / 2)。
求めたアスキーコードを Chr() で文字に変換して、抽出された文字列(strText)に順次追加していきます。

[ 4 ] 取得した文字列を表示する

すべての色付きセルについて上記処理が終了したら、表示先セルに抽出された文字列を表示します。

【初期化処理】

「埋め込む文字列」、「抽出した文字列」、「着色されたセル」を初期化(クリア)する処理です。特に解説は不要でしょう。

Public Sub Click_クリア()
    With wsMain
        .Range(RNG_TEXT).ClearContents
        .Range(RNG_DECODE_TEXT).ClearContents
        .Cells.Interior.ColorIndex = xlNone
    End With
End Sub

ボタンに書く処理を割り当てて完成

あとは適当にボタンを作って、「Click_埋め込む()」、「Click_抽出する()」、「Click_クリア()」の処理を割り当てれば完成です。
いろいろな文字列でどんな色になるか試してみましょう!

これの用途

まぁ、これが何に使えるのかっていうのは…私もよくわかりません。。暗号?
でも、おもしろいからいいよね!


f:id:celaeno42:20181212233850p:plain

【VBA編】ニューラルネットワーク(マクロの登録)

f:id:celaeno42:20181115232506p:plain

マクロの登録

各ボタンにマクロを登録します。

ボタン プロシージャ名
データ読み込み Click_データ読み込み
重みクリア Click_学習状況クリア
学習開始 Click_学習開始
テスト開始 Click_テスト開始

データ読み込み

C2セル、C3セルをダブルクリックして、データ用のCSVファイルを選択します。
【データ読み込み】ボタンを押下すると、CSVファイルのデータが読み込まれます。

学習開始

【学習開始】ボタンを押下すると、訓練データによる学習が開始されます。
ロスの値が学習終了判定値を下回るか、エポック数が最大エポック数を超えると学習を終了します。
学習が終了すると、正解数、正解率が計算されます。

テスト開始

【テスト開始】ボタンを押下すると、テストデータによるテストが実行されます。
学習に使われていないテストデータでどれくらい正解するかを調べ、正しく学習されていることを確認します。
なお、学習前に【テスト開始】をした場合、ニューラルネットワークはいいかげんな判断を行います。

重みクリア

学習により求められた重みの値をクリアします。
重みがクリアされるので、ニューラルネットワークは学習していない状態に戻ります。


f:id:celaeno42:20181212233850p:plain

【VBA編】ニューラルネットワーク(mdlSupervisor)

スーパーバイザ

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

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

【VBA編】ニューラルネットワーク(classOutputLayer)

出力層クラス

出力層のユニットを管理するクラスです。

'[classOutputLayer - 出力層クラス]
Option Explicit
Option Base 1

Dim mUnitList() As classUnit        'ユニット格納用リスト
Dim mUnitCount As Long              '自レイヤーのユニット数
Dim mAct As Long                        '活性関数の種類
Dim mWeightCount As Long            '自レイヤーに属するユニットが持つ重みの数
Dim mInputDataList() As Double
Dim mDeltaList() As Double

'自レイヤーのユニットを作成する
'[引数] <- aUnitCount : Long / ユニットの数, aInputCount : Long / 入力データの数, aActivationFunction : Long / 活性化関数の種類
Public Sub Initialize(ByRef aUnitCount As Long, ByRef aInputCount As Long, ByRef aActivationFunction As Long)
    Dim i As Long
    
    ReDim mUnitList(aUnitCount)
    
    '必要な数だけユニットを作成しユニット格納用リストに格納する
    For i = 1 To aUnitCount
        Set mUnitList(i) = New classUnit
        'Newしたユニットを初期化する
        Call mUnitList(i).Initialize(aInputCount)
    Next
    
    mUnitCount = aUnitCount
    mAct = aActivationFunction
    mWeightCount = aInputCount

End Sub

'順伝播:各ユニットのuとzを求める
'[引数] <- aInputDataList() : Double / 入力データのリスト
Public Sub Forward(ByRef aInputDataList() As Double)
    Dim i As Long
    
    'ユニットに入力値を渡して u を計算する
    For i = 1 To mUnitCount
        Call mUnitList(i).CalcU(aInputDataList)
    Next
    
    '活性化関数を適用して z を計算する
    Call activateU
    
    'バックプロパゲーション用に入力値を覚えておく
    mInputDataList = aInputDataList
    
End Sub

'次の層に渡すための出力リストを準備する
'[戻り値] -> OutputDataList() : Double / 自層の各ユニットの出力値のリスト
Public Function OutputDataList() As Double()
    Dim i As Long
    Dim outputDatas() As Double
    
    ReDim outputDatas(mUnitCount)
    
    For i = 1 To mUnitCount
        outputDatas(i) = mUnitList(i).Z
    Next
    
    OutputDataList = outputDatas()
    
End Function

'ユニットの u に活性化関数を適用する
Private Sub activateU()

    If mAct = ACT.Softmax Then
        Call activationSoftmax
    End If

End Sub

'ユニットの u にSoftmaxを適用する
Private Sub activationSoftmax()
    Dim i As Long
    Dim uList() As Double
    
    'Softmaxの計算には全出力値が必要となるため、配列に格納
    ReDim uList(mUnitCount)
    
    For i = 1 To mUnitCount
        uList(i) = mUnitList(i).U
    Next
    
    For i = 1 To mUnitCount
        mUnitList(i).Z = ML.actSoftmax(uList, i)
    Next
    
End Sub

Public Sub Backprop(ByRef aT() As Long)
    Dim i As Long
    Dim Z() As Double
    
    Z = OutputDataList
    
    ReDim mDeltaList(mUnitCount)
    For i = 1 To mUnitCount
        mDeltaList(i) = Z(i) - aT(i)
        
        'ユニットの重みを更新
        Call mUnitList(i).Backprop(mDeltaList(i), mInputDataList)

    Next
    
End Sub

Public Function deltaList() As Double()
    deltaList = mDeltaList
End Function

Public Function GetWeightList(ByRef aWeightIndex As Long) As Double()
    Dim i As Long
    Dim res() As Double
    
    ReDim res(mUnitCount)
    For i = 1 To mUnitCount
        res(i) = mUnitList(i).GetW(aWeightIndex)
    Next
    
    GetWeightList = res
    
End Function

'最も大きい出力値のユニットのインデックスを返す
Public Function GetAnswerIndex() As Long
    Dim i As Long
    Dim ans As Long
    
    ans = 1
    For i = 2 To mUnitCount
        If mUnitList(i).Z > mUnitList(ans).Z Then
            ans = i
        End If
    Next
    
    GetAnswerIndex = ans
    
End Function

Public Function GetAnswerRate(ByRef aIndex As Long) As Double
    GetAnswerRate = mUnitList(aIndex).Z
End Function

Public Sub SaveWeight(ByRef aSh As Worksheet)
    Dim i As Long
    Dim j As Long
    
    With aSh
        .Cells.Clear
        
        For i = 1 To mUnitCount
            .Cells(i, 1).Value = mUnitList(i).GetBias
            For j = 1 To mWeightCount
                .Cells(i, j + 1).Value = mUnitList(i).GetW(j)
            Next
        Next
    
    End With
    
End Sub

'重みとバイアスの値をシートから読み込む
'[引数] <- aSh : Worksheet / 読み込み先のシート
Public Sub LoadWeight(ByRef aSh As Worksheet)
    Dim i As Long
    Dim j As Long
    
    With aSh
        For i = 1 To mUnitCount
            Call mUnitList(i).SetBias(.Cells(i, 1).Value)
            For j = 1 To mWeightCount
                Call mUnitList(i).SetW(j, .Cells(i, j + 1).Value)
            Next
        Next
    
    End With
    
End Sub


f:id:celaeno42:20181212233850p:plain

【VBA編】ニューラルネットワーク(classHiddenLayer)

隠れ層

隠れ層のユニットを管理するクラスです。

'[classHiddenLayer - 隠れ層クラス]
Option Explicit
Option Base 1

Dim mUnitList() As classUnit        'ユニット格納用リスト
Dim mUnitCount As Long              '自レイヤーのユニット数
Dim mAct As Long                        '活性関数の種類
Dim mWeightCount As Long         '自レイヤーに属するユニットが持つ重みの数
Dim mInputDataList() As Double      '入力用データリスト
Dim mDeltaList() As Double              '逆伝播時の勾配格納用リスト

'自レイヤーのユニットを作成する
'[引数] <- aUnitCount : Long / ユニットの数, aInputCount : Long / 入力データの数, aActivationFunction : Long / 活性化関数の種類
Public Sub Initialize(ByRef aUnitCount As Long, ByRef aInputCount As Long, ByRef aActivationFunction As Long)
    Dim i As Long
    
    ReDim mUnitList(aUnitCount)
    ReDim mDeltaList(aUnitCount)
    
    '必要な数だけユニットを作成しユニット格納用リストに格納する
    For i = 1 To aUnitCount
        Set mUnitList(i) = New classUnit
        'Newしたユニットを初期化する
        Call mUnitList(i).Initialize(aInputCount)
    Next
    
    mUnitCount = aUnitCount
    mAct = aActivationFunction
    
    mWeightCount = aInputCount

End Sub

'順伝播:各ユニットのuとzを求める
'[引数] <- aInputDataList() : Double / 入力データのリスト
Public Sub Forward(ByRef aInputDataList() As Double)
    Dim i As Long
    
    'ユニットに入力値を渡して u を計算する
    For i = 1 To mUnitCount
        Call mUnitList(i).CalcU(aInputDataList)
    Next
    
    '活性化関数を適用して z を計算する
    Call activateU
    
'    バックプロパゲーション用に入力値を覚えておく
    mInputDataList = aInputDataList
    
End Sub

'次の層に渡すための出力リストを準備する
'[戻り値] -> OutputDataList() : Double / 自層の各ユニットの出力値のリスト
Public Function OutputDataList() As Double()
    Dim i As Long
    Dim outputDatas() As Double
    
    ReDim outputDatas(mUnitCount)
    
    For i = 1 To mUnitCount
        outputDatas(i) = mUnitList(i).Z
    Next
    
    OutputDataList = outputDatas()
    
End Function

'ユニットの u に活性化関数を適用する
Private Sub activateU()

    If mAct = ACT.ReLU Then
        Call activationReLU
    End If

End Sub

'ユニットの u にReLUを適用する
Private Sub activationReLU()
    Dim i As Long
    
    For i = 1 To mUnitCount
        mUnitList(i).Z = ML.actReLU(mUnitList(i).U)
    Next
    
End Sub

Private Function calcDiff(ByRef aU As Double) As Double
    Dim res As Double
    
    If mAct = ACT.ReLU Then
        res = diffReLU(aU)
    End If
    
    calcDiff = res

End Function

Private Function diffReLU(ByRef aU As Double) As Double
    Dim res As Double
    
    If aU > 0 Then
        res = 1#
    Else
        res = 0#
    End If
    
    diffReLU = res
End Function

Public Sub Backprop(ByRef aIndex As Long, ByRef aDeltaList() As Double, ByRef aWeightList() As Double)
    Dim i As Long
    Dim delta As Double
    
    For i = 1 To UBound(aDeltaList)
            
        delta = delta + (aDeltaList(i) * aWeightList(i) * calcDiff(mUnitList(aIndex).U))
            
    Next
    
    mDeltaList(aIndex) = delta
    
    'ユニットの重みを更新
    Call mUnitList(aIndex).Backprop(delta, mInputDataList)
    
End Sub

Public Function deltaList() As Double()
    deltaList = mDeltaList
End Function

Public Function GetWeightList(ByRef aWeightList As Long) As Double()
    Dim i As Long
    Dim res() As Double
    
    ReDim res(mUnitCount)
    For i = 1 To mUnitCount
        res(i) = mUnitList(i).GetW(aWeightList)
    Next
    
    GetWeightList = res
    
End Function

Public Sub SaveWeight(ByRef aSh As Worksheet)
    Dim i As Long
    Dim j As Long
    
    With aSh
        .Cells.Clear
        
        For i = 1 To mUnitCount
            .Cells(i, 1).Value = mUnitList(i).GetBias
            For j = 1 To mWeightCount
                .Cells(i, j + 1).Value = mUnitList(i).GetW(j)
            Next
        Next
    
    End With
    
End Sub

'重みとバイアスの値をシートから読み込む
'[引数] <- aSh : Worksheet / 読み込み先のシート
Public Sub LoadWeight(ByRef aSh As Worksheet)
    Dim i As Long
    Dim j As Long
    
    With aSh
        For i = 1 To mUnitCount
            Call mUnitList(i).SetBias(.Cells(i, 1).Value)
            For j = 1 To mWeightCount
                Call mUnitList(i).SetW(j, .Cells(i, j + 1).Value)
            Next
        Next
    
    End With
    
End Sub


f:id:celaeno42:20181212233850p:plain

【VBA編】ニューラルネットワーク(classInputLayer)

入力層のユニット管理

入力層のユニットを管理するためのクラスです。

'[classInputLayer - 入力層のユニットを管理するためのクラス]
Option Explicit
Option Base 1

Dim mInUnitList() As classInputUnit     'ユニット格納用リスト
Dim mInUnitCount As Long                  '入力層のユニット数

'入力層のユニットに入力値を格納する
'[引数] <- aInputDataList() : Double / 入力値のリスト
Public Sub DataInput(ByRef aInputDataList() As Double)
    Dim i As Long
    Dim cInUnit As classInputUnit
    
    mInUnitCount = UBound(aInputDataList)
    
    ReDim mInUnitList(mInUnitCount)
    
    For i = 1 To mInUnitCount
        Set mInUnitList(i) = New classInputUnit
        mInUnitList(i).X = aInputDataList(i)
    Next
    
End Sub

'入力層のユニットの出力値を得る
'[戻り値] -> OutputDataList() : Double / 出力値のリスト
Public Function OutputDataList() As Double()
    Dim i As Long
    Dim outputDatas() As Double
    
    ReDim outputDatas(mInUnitCount)
    
    For i = 1 To mInUnitCount
        outputDatas(i) = mInUnitList(i).X
    Next
    
    OutputDataList = outputDatas()
    
End Function


f:id:celaeno42:20181212233850p:plain