エクセルVBAでヒープソート - 午後わてんのブログ

ついにヒープソートなんだけど、その前に選択ソート

選択ソート - Wikipedia
https://ja.wikipedia.org/wiki/%E9%81%B8%E6%8A%9E%E3%82%BD%E3%83%BC%E3%83%88

最小値を探し出して順番に並べるだけ

最初は配列全体から最小値を探す、見つかった値は配列の1番左と交換

次は左から2番目以降から最小値を探す、見つかった値は左から2番めと交換

次は左から3番目以降から...これを繰り返して右端まで行ったら完了

Public Sub SelectSort2(v As Variant)
    Dim i As Long, tmp As Variant, min As Variant
    Dim p As Long
    For i = LBound(v) To UBound(v) - 1
        min = v(i)
        p = i '最小値のIndex入れる用
        For j = i + 1 To UBound(v)
            If min > v(j) Then
                min = v(j)
                p = j '最小値のIndex
            End If
        Next
       '交換
        tmp = v(i)
        v(i) = min
        v(p) = tmp
    Next
End Sub

比較する回数はバブルソートと変わらないから遅いのかなあと予想しつつ

1万件をソートの時間計測

4.4804秒

バブルソートは10秒だったから2倍以上速い！

コード的にはバブルソートより簡単な気がするんだけどね、速い

ここから本番のヒープソート

ヒープソートと選択ソートに共通しているのが最小値(か最大値)を探し出して順番に並べるってところ

違うのは探す方法

ヒープソートはヒープ(ヒープ構造)ってのを使って探す

ヒープってのは日本語だと二分木らしい

けどどっちも聞いたことないよ

形で言うとこういうのがヒープらしい親と子があって親のしたには子が2つある状態、

親から2つ分かれているから二分木なのかも

これだと要素を3つしか扱えないけど、子の下にさらに子を付け足していくことができる、親から見たら孫みたいね

こんなふうにどんどん増やせる

番号を付ける

上から下へ、左から右へ順番に番号をつけていくと都合がいい

0番の子は1番と2番ってことになって

1番の親は0番、1番の子は3番と4番

5番の親は2番ってことがわかる

中途半端な変な形

要素数が増えて8個の場合はこうなる

3番の子は7番しかないけどこの形でもヒープ

順番に番号をつけられたってことは配列と同じように使えるってこと

v = Array(1, 3, 2)

っていう配列をヒープに当てはめていくと↓になる

●の右上の数値は番号で

●の中は配列の値

少し戻って

ヒープには親が上で子が下にあるっていう位置関係以外にもルールがあって

親の数値＞＝子の数値

親は子の数値より大きいことがヒープの条件

さっきの配列をヒープに当てはめたのを見ると、0番の数値1は子の数値3と2よりも小さいのでヒープじゃないってことなる

正しいヒープに修正するには上から見ていく方法と下からがあるみたい

今回は上から見ていくので0番から

0番の子は1番と2番、どちらの数値も親より大きいけど、より大きい方と交換する

交換したところ

これで正しいヒープになった

こういうのを繰り返していくと一番上が最大値になるのでこれを取り出して順番に並べると整列できるってのがヒープソートみたい

自分の親や子の番号を求める方法

親の番号を求める

親や子と比較するときはその番号が必要になる

配列の添字が0からの場合の自分の親の番号の求め方

(自分の番号-1)\2

\は割り算の商部分(小数点以下切り捨て)なので

例えば自分の番号が4なら親の番号は

(4-1)/2=1.5=1

図で見ても4番の親は1番であっている

0番から14番までの親の番号一覧で確認

Quotientは割り算の商を返す

配列の添字が0番から始まっていればこれで行けるんだけど0以上のときは使えなくて

(自分の番号 + 開始添字 - 1) \ 2

になる

4から始まる配列で7番の親番号は

(7+4-1)/2=5

5番であっている

これも一覧で確認してみる

1番から始まるときもこれでOK

今度は子の番号を求める

左の子＝自分の番号*2+1

右の子＝自分の番号*2+2、または左＋1

自分が2番のときの子の番号は

左=2*2+1=5

右=2*2+2=6

あってる

これも添字が0からの配列の場合だけなので

0以上から始まる配列のときは

左の子＝自分の番号 * 2 - (開始添字 - 1)

右の子＝自分の番号 * 2 - (開始添字)、または左＋1

これで準備が整ったので配列をヒープにしていく

添字は0から始まる配列Array(5, 3, 1, 4, 6, 2)を0番から順番に

0番に5を入れて、1番に3を入れたところ

親の番号は

(自分の番号-1)\2

なので

(1-1)\2=0番

親は0番

親(5)>子(3)のルールはあっているので次へ

2番に1を入れたところ

2番の親の番号は(2-1)\2=0で0番

比較して

これもあっているので次へ

3番に4を追加

3番の親の番号は(3-1)\2=1で1番

比較すると自分(子)のほうが大きいので交換

交換した

交換した先の関係を見る

1番の親の番号は0番

比較すると今度はあっているので次へ

4番に6を追加

4番の親の番号は(4-1)\2=1で1番

比較すると自分(子)のほうが大きいので交換

1番と4番を交換した

交換した先の関係を見る

1番の親の番号は0番

比較すると子のほうが大きいので交換

0番と1番を交換した

交換した先の関係を見る

0番の親はないので次へ

5番に次の値(2)を追加した

5番の親の番号は(5-1)\2=2で2番

比較すると子のほうが大きいので交換

2番と5番を交換した

交換した先の関係を見ると

2番の親の番号は0番

比較するとあっているので次へ

配列の最後の要素まで来たので終了

元の配列の並びはArray(5, 3, 1, 4, 6, 2)こうだったのが

(6, 5, 2, 3, 4, 1)となった、まだ整列(ソート)できていないけどヒープ構造にはなっている

一つ一つの最小単位のヒープでは親の値>子の値というルールは守られている

この状態になると一番上(0番)には最大値が入るはずなので

最大値が判明したことになる

ここまでをVBAにしたのが

Dim i As Long, j As Long, tmp As Variant
Dim p As Long 'parent index親番号
Dim ei As Long 'end index、自分の番号(最後尾番号)
For i = 1 To UBound(v)
    ei = i
    p = (ei - 1) \ 2 '親番号
   '親の値＞子の値になるまで交換ループ
    Do While v(p) < v(ei)
       '比較して必要なら交換を繰り返す
        tmp = v(p)
        v(p) = v(ei)
        v(ei) = tmp
        ei = p
        p = (ei - 1) \ 2 '親番号
    Loop
Next

外側のループはFor～Nextをつかっている、1から開始して配列の最後までループ、0からじゃないのは0番の親はないから

内側のループはDo While～Loopをつかっている、追加した自分の親の値と比較して自分のほうが大きければ交換、交換した先でも親と比較して必要なら交換を繰り返して自分のほうが小さくなるまでこのループを続けるのでループ条件は

親の値 < 自分の値、v(p) < v(ei)

ループを抜けたら外側のループなので2番3番と同じように追加していく

Array(5, 3, 1, 4, 6, 2)を渡すと

(5, 3, 1, 4, 6, 2)→(6, 5, 2, 3, 4, 1)

図で見ると

こうなった、あっている

0番には最大値が入っているし小さな単位のヒープは

親の値 > 子の値という正しい状態

次はは整列していく作業

最大値がある0番と最後尾の5番を交換する

交換した

5番は最大値が入ったので整列済みになるので以降は無視して、残りの0番から4番までを作業の対象にする

次は交換した0番のせいでヒープが崩れてしまったので修正していく、0番から見ていく

図を見れば0番と1番を交換すればいいのがわかる

まず子同士の比較をして大きい方と親(自分)を比較する

子のほうが大きければ交換、小さければそのまま

0番は一番上で必ず親なので子の番号を求める

子の番号は

左の子＝自分の番号*2+1

右の子＝自分の番号*2+2、または左＋1

なので

左=0*2+1=1

右=0*2+2=2

1番と2番を比較して大きいのは1番

1番と0番を比較して1番のほうが大きいので交換になる

交換した

次も同じように子とのヒープ状態をみて正しくなければ交換していく

図を見ればわかるけど1番と4番を入れ替えれば正しくなる

1番の子の番号は

左＝1*2+1=3、右=1*2+2=4、比較して4番のほうが大きい

4番と自分を比較して4番のほうが大きいので交換

交換した

4番の子は無いのでこれで修正は完了

ヒープが正しくなると0番に最大値が入っていることになるので

0番と最後尾の4番を交換する

最後尾といっても5番じゃなくて4番になるのは

5番はもう整列済みで無視するところだから

交換した

これで5番に続き4番も整列済みなので以降は無視、対象外

次はまた0番を交換したせいでヒープが崩れたので

0番から修正していく

0番と1番を交換した

1番の子は3番と4番になっているけど4番は整列済みなので

3番と比較、交換になる

1番と3番を交換した

修正完了したので0番と最後尾を入れ替える

交換した

これで3番から5番まで整列済み

また0番から修正していく

0番と1番を交換

1番の子は整列済みなので修正完了

0番を最後尾と交換する

交換した

今度は0番を見てもヒープは正しいので修正無しでOK

0番と最後尾を交換

交換した

0番以外は整列済みで比較対象がなくなったので

全て整列済みになる

ヒープソート完成！

ここまでの修正しながらの整列をVBAにすると

'上から修復
'ソート部分
Dim c1 As Long  'child1 index
Dim c2 As Long  'child2 index
Dim k As Long
For ei = UBound(v) To 1 Step -1
    p = 0 'ParentIndex初期化
    Do
       '子同士の比較、大きい方のIndex取得
        c1 = p * 2 + 1 '左の子Index
        c2 = c1 + 1   '右の子
        If c2 > ei Then   '右Indexが最後尾を超えていたら
            k = c1   '自動的に左Indexを採用
        ElseIf v(c1) > v(c2) Then '子同士の比較
            k = c1
        Else
            k = c2
        End If

       '自分(親)と大きい方の子を比較
        If v(k) > v(p) Then
           '子が大きければ交換
            tmp = v(k)
            v(k) = v(p)
            v(p) = tmp
            p = k '自分のIndexを入れ替えた先のIndexに変更
        Else
           '子が小さければ修復完了
            Exit Do
        End If
   '自分の左の子がなくなるまでループ
    Loop While p * 2 + 1 < ei

   '先頭(最大値)とソート範囲の最後尾を入れ替える
    tmp = v(0)
    v(0) = v(ei)
    v(ei) = tmp
Next

ループは2つ、外側のループは要素の総数から1づつ減らしていって1になるまでループ、減らしていっているのは整列済みがどんどん増えていくからその分を除くため

内側のループはDo～Loopでループ条件の

p * 2 + 1 < eiは

左の子の番号 < 最後尾番号

つまり自分の子がなくなるまでループ

内側ループの前半は子同士の比較をして大きい方の番号を取得

後半はその大きい方の子と自分を比較して子が小さければ修復完了なので内側ループ抜けして、大きければ交換してループを続ける

内側ループが終わったら最大値と最後尾を交換して外側ループ

最後尾番号が1になったらソート完了

これでソート部分もできたのでさっきの配列をヒープにしていくのと合わせるとヒープソートの完成↓

'添字が0から始まる配列だけに対応したヒープソート
Public Function HeapSort3_1(v As Variant) As Variant
    Dim i As Long, j As Long, tmp As Variant
    Dim p As Long 'parent index親番号
    Dim ei As Long 'end index、最後尾番号

   'ヒープ構造作成
   '元の配列をそのまま使う
    For i = 1 To UBound(v)
        ei = i
        p = (ei - 1) \ 2 '親番号
       '親の値＞子の値になるまで交換ループ
        Do While v(p) < v(ei)
           '比較して必要なら交換を繰り返す
            tmp = v(p)
            v(p) = v(ei)
            v(ei) = tmp
            ei = p
            p = (ei - 1) \ 2 '親番号
        Loop
    Next

   '上から修復ソート部分
    Dim c1 As Long  'child1 index
    Dim c2 As Long  'child2 index
    Dim k As Long
    For ei = UBound(v) To 1 Step -1
        p = 0 'ParentIndex初期化
        Do
           '子同士の比較、大きい方のIndex取得
            c1 = p * 2 + 1 '左の子Index
            c2 = c1 + 1   '右の子
            If c2 > ei Then   '右Indexが最後尾を超えていたら
                k = c1   '自動的に左Indexを採用
            ElseIf v(c1) > v(c2) Then '子同士の比較
                k = c1
            Else
                k = c2
            End If
            
           '自分(親)と大きい方の子を比較、子が大きければ交換
            If v(k) > v(p) Then
                tmp = v(k)
                v(k) = v(p)
                v(p) = tmp
                p = k '自分のIndexを入れ替えた先のIndexに変更
            Else
                Exit Do
            End If
        Loop While p * 2 + 1 < ei
        
       '先頭(最大値)とソート範囲の最後尾を入れ替える
        tmp = v(0)
        v(0) = v(ei)
        v(ei) = tmp
    Next

    HeapSort3_1 = v
End Function

やっとできたヒープソートはどれくらい速いのか

ランダム数値の1万件ソート

5回計測、平均すると0.085秒

速い！

今までのまとめ

f:id:gogowaten:20191031110722p:plain

だんだん長くなってきた

グラフで

コムソートとシェルソートには及ばずだけど

前回のマージソートよりは速い結果になった

バブル、シェーカーの遅い組

挿入、選択の中間組

コム、シェル、マージ、ヒープの速い組

3つに分かれる感じかなあ

100万件ソート

12.6秒

あれ、遅い？

1万件ではマージソートより速かったのに

100万件にしたら逆転してしまった

参照したところ

ヒープソート(heap sort)
http://www.moon.sannet.ne.jp/okahisa/sort/node20.html

Programming Place Plus　アルゴリズムとデータ構造編【データ構造】　第９章　ヒープ
http://ppp-lab.sakura.ne.jp/ProgrammingPlacePlus/algorithm/data_struct/009.html

VBA ヒープソートを実装～関数を沢山作って複雑な問題に対処する - t-hom’s diary
http://thom.hateblo.jp/entry/2017/03/20/202940

ヒープソート
 http://www.th.cs.meiji.ac.jp/researches/2005/omoto/heapsort.html

マージソートも難しかったけどヒープソートはさらに時間がかかった、4日くらいかかってやっとまともなのができたんだったかなあ

最初できたのは1万件をソートで10分(815秒)以上もかかるものだったｗ

そこから一応これくらいなのかなっていう1秒台まで縮めたあとは一旦諦めてマージソートを書いていたみたいで、その後に何か思いついて0.1秒になって今回の0.085秒までは1週間くらいかかったのかなあ、それでも理解できていないから本当はもっと速いのかも、でももうヒープソートはお腹いっぱい

残るは最速と言われているクイックソートなんだけど、これが全然わかんなくて3秒もかかるものしか書けてない

'開始添字が0以上でもOKのヒープソート

さっきのヒープソートは添字は0からしか対応していないけど、エクセルでは1から始まる配列を扱うことが多いので書いた

ほとんど一緒で違うのはループの条件とループの開始位置

Public Function HeapSort4_1(v As Variant) As Variant
    Dim i As Long, j As Long, tmp As Variant
    Dim c As Long
    Dim min As Long: min = LBound(v)
    Dim ei As Long 'end index
   'ヒープ構造作成
   '元の配列をそのまま使う
    For i = min + 1 To UBound(v)
        ei = i
        p = (ei + min - 1) \ 2
        Do While p > min And v(p) < v(ei)
            tmp = v(p)
            v(p) = v(ei)
            v(ei) = tmp
            ei = p
            p = (ei + min - 1) \ 2
        Loop
    Next

   '上から修復
   'ソート部分
    Dim c1 As Long  'child1 index
    Dim c2 As Long  'child2 index
    Dim k As Long
    ei = UBound(v)
    For ei = UBound(v) To min + 1 Step -1
        p = min 'ParentIndex初期化

        Do
           '子同士の比較、大きい方のIndex取得
            c1 = p * 2 - (min - 1) '左の子Index
            c2 = c1 + 1     '右の子
            If c2 > ei Then '右Indexが最後尾を超えていたら
                k = c1      '自動的に左Indexを採用
            ElseIf v(c1) > v(c2) Then '子同士の比較
                k = c1
            Else
                k = c2
            End If
           '自分(親)と大きい方の子を比較、子が大きければ交換
            If v(k) > v(p) Then
                tmp = v(k)
                v(k) = v(p)
                v(p) = tmp
                p = k '自分のIndexを入れ替えた先のIndexに変更

            Else
                Exit Do
            End If
        Loop While p * 2 - (min - 1) < ei

       '先頭(最大値)とソート範囲の最後尾を入れ替える
        tmp = v(min)
        v(min) = v(ei)
        v(ei) = tmp
    Next
    HeapSort4_1 = v
End Function

これを使ってSheet3のA1からA10000をソートしてB列に貼り付けるマクロ

Sub bubble1000()
    Dim v() As Variant
    Dim y As Long: y = 10000
    v = WorksheetFunction.Transpose(Sheets("Sheet3").Range("a1:a" & y))
    v = HeapSort4_1(v)
    Sheets("Sheet3").Range("b1:b" & y) = WorksheetFunction.Transpose(v)
End Sub