initial.bas

vb apriori algorithm

Attribute VB_Name = "initial"
Public Declare Function GetCurrentTime Lib "kernel32" Alias "GetTickCount" () As Long
Public Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Type ItemNode
ItemStr As String
ItemStrCount As Long
End Type


''******************************************************************************
Global Gendata_rs As ADODB.Recordset
Global Gendata_rs_2 As ADODB.Recordset
Global Gendata_cnn As ADODB.Connection

Global change_or_not As Long   '判断工作状态是够发生改变
Global begin_time As Long         '状态改变开始的时间
Global change_time As String      '状态改变的时间
Global work_time As Long          '总的工作时间
Global non_work_time As Long      '总的非工作时间
Global work_status As Long
Global work_status_new As Long
Global work_status_old As Long
Global end_time As Long
Global Sparetime As Long
Global mean, deviation As Single
Global normaldistribut(1 To 20) As Single        '正态分布中平均数=6 标准差=4 时1~20的分布频率
Global normaldistribut_TNum(1 To 20) As Long   '（正态分布）含有1~20种商品的交易的数目
Global ItemUpperBound As Long '所有交易品的数量
Global itemnum() As Long    '每个交易的交易商品的数字表示
Global ItemString As String '每个交易的交易商品的品名字符串
Global ItemCount() As Long
Global SupportThreshold1, SupportThreshold2, ConfidenceThreshold As Single
Global TotalTransNum As Long
Global temp() As ItemNode
Global L1() As ItemNode
Global C2() As ItemNode
Global L2() As ItemNode
Global L1Num, L2Num As Long 'L1中元素个数 L1Num+1
Global ItemStr() As String   'StrDecompose Candidate字符串 中字符串分解后的字符数组 在SubSet中比较使用
Global C2TotalNum, C2Num As Long

Global H2() As ItemNode
Global H2CountMax As Long
Global FrqNumArray(0 To 17) As Long
Global returnnumber As Long


Public Sub main()
Frm_gendata.Combo1.AddItem "100*1000"
Frm_gendata.Combo1.AddItem "1000 * 10000"
Frm_gendata.Combo1.AddItem "1000 * 100000"
Dim H2num As Long
ItemUpperBound = 100
mean = 6
deviation = 4
SupportThreshold1 = 0.05
SupportThreshold2 = 0.05
ConfidenceThreshold = 0.6
'For i = 1 To 100
    'ItemCount(i) = 0
'Next i
H2num = (ItemUpperBound * (ItemUpperBound - 1) / 2) - 1
ReDim H2(0 To H2num)
NormalDistributing (100000)
TotalTransNum = 0
Dim i, j As Long
For i = 1 To 20
    TotalTransNum = TotalTransNum + normaldistribut_TNum(i)
Next i
'For j = 0 To 5
'TestSame:    Randomize
    'frqnumarray(j) = itemupperbound * Rnd
    'If frqnumarray(j) = 1000 Then
        'GoTo TestSame
    'End If
        'If j = 1 Then
        'Else
            'For l = 1 To j - 1
                'If (frqnumarray(j) - frqnumarray(l)) = 0 Then
                    'GoTo TestSame
                'Else
                'End If
            'Next l
        'End If
'Next j

FrqNumArray(0) = 95
FrqNumArray(1) = 32
FrqNumArray(2) = 45
FrqNumArray(3) = 58
FrqNumArray(4) = 69
FrqNumArray(5) = 88
FrqNumArray(6) = 11
FrqNumArray(7) = 33
FrqNumArray(8) = 46
FrqNumArray(9) = 59
FrqNumArray(10) = 70
FrqNumArray(11) = 90
FrqNumArray(12) = 13
FrqNumArray(13) = 35
FrqNumArray(14) = 48
FrqNumArray(15) = 60
FrqNumArray(16) = 72
FrqNumArray(17) = 99

'normaldistribut_TNum(19) = 50
'normaldistribut_TNum(20) = 50
Frm_gendata.Enabled = True
Frm_gendata.Visible = True
End Sub
Public Function NormalDistributing(ByVal TransNum)
normaldistribut(1) = 0.1056
normaldistribut(2) = 0.0531
normaldistribut(3) = 0.0679
normaldistribut(4) = 0.0819
normaldistribut(5) = 0.0928
normaldistribut(6) = 0.0987
normaldistribut(7) = 0.0987
normaldistribut(8) = 0.0928
normaldistribut(9) = 0.0819
normaldistribut(10) = 0.0679
normaldistribut(11) = 0.0531
normaldistribut(12) = 0.0388
normaldistribut(13) = 0.0267
normaldistribut(14) = 0.0173
normaldistribut(15) = 0.0106
normaldistribut(16) = 0.006
normaldistribut(17) = 0.0032
normaldistribut(18) = 0.0017
normaldistribut(19) = 0.0007
normaldistribut(20) = 0.0007
Dim i, j As Long
For i = 1 To 20
    normaldistribut_TNum(i) = Int(normaldistribut(i) * TransNum)
Next i

End Function
Sub QuickSort(MyArray() As Long, l, R)
Dim i, j, x, Y

    i = l
    j = R
    x = MyArray((l + R) / 2)
        
    While (i <= j)
        While (MyArray(i) < x And i < R)
            i = i + 1
        Wend
        While (x < MyArray(j) And j > l)
            j = j - 1
        Wend
        If (i <= j) Then
            Y = MyArray(i)
            MyArray(i) = MyArray(j)
            MyArray(j) = Y
            i = i + 1
            j = j - 1
        End If
        gIterations = gIterations + 1
    Wend

    If (l < j) Then Call QuickSort(MyArray(), l, j)
    If (i < R) Then Call QuickSort(MyArray(), i, R)

End Sub
Public Function GenrndItem(upperbound As Long)
Dim i, j, k, l, m As Long
Dim a As Long
ReDim ItemCount(0 To upperbound - 1)
ItemUpperBound = upperbound
itemlowerbound = 1
For i = 1 To 20
    'ReDim ItemNum(normaldistribut_TNum(i)) As long
    For j = 1 To normaldistribut_TNum(i)
        ReDim itemnum(1 To i)
        ItemString = ""
        For k = 1 To i
TestSame:   Randomize
            itemnum(k) = GenRndNum(4, 2, 6)
            If itemnum(k) = ItemUpperBound Then
                GoTo TestSame
            Else
            End If
            If k = 1 Then
            Else
                For l = 1 To k - 1
                    If (itemnum(k) - itemnum(l)) = 0 Then
                        GoTo TestSame
                    Else
                    End If
                Next l
            End If
        Next k
        If i = 1 Then
        Else
            Call QuickSort(itemnum(), 1, UBound(itemnum))
        End If
        For m = 1 To i
            If itemnum(m) < 100 Then
                If itemnum(m) >= 10 Then
                    ItemString = ItemString + "I" + "0" + CStr(itemnum(m))
                Else
                    ItemString = ItemString + "I" + "00" + CStr(itemnum(m))
                End If
            Else
                ItemString = ItemString + "I" + CStr(itemnum(m))
            End If
        Next m
            Gendata_rs.AddNew
            Gendata_rs!item = ItemString
            Gendata_rs.Update
            Gendata_rs.MoveNext

    Next j
Next i
End Function
Public Function ItemStringDecompose(ItemStr As String)
Dim mystring, mychar As String
Dim beginpos, endpos, pos, strlen, Num As Long
mychar = "I"
beginpos = 1 + 1
endpos = 1
mystring = ItemStr
strlen = Len(mystring)
Do While (InStr(beginpos, mystring, mychar, vbTextCompare))
    pos = InStr(beginpos, mystring, mychar, vbTextCompare)
    Num = Val(Mid(mystring, beginpos, (pos - beginpos)))
    ItemCount(Num) = ItemCount(Num) + 1
    beginpos = pos + 1
Loop
    Num = Val(Mid(mystring, beginpos, (strlen - beginpos)))
    ItemCount(Num) = ItemCount(Num) + 1
End Function
Public Function GenL1(ByRef itemnum As Long, ByRef L1Temp() As ItemNode)
L1Num = 0
Dim temp() As ItemNode
ReDim temp(0 To itemnum - 1)
For i = 0 To itemnum - 1
    If (L1Temp(i).ItemStrCount / TotalTransNum) >= SupportThreshold1 Then
        temp(L1Num).ItemStr = L1Temp(i).ItemStr
        temp(L1Num).ItemStrCount = L1Temp(i).ItemStrCount
        L1Num = L1Num + 1
    End If
Next i
If L1Num > 0 Then
    ReDim L1(0 To L1Num - 1)
    For j = 0 To L1Num - 1
        L1(j).ItemStr = temp(j).ItemStr
        L1(j).ItemStrCount = temp(j).ItemStrCount
    Next j
Else
    MsgBox "there no such frequent 1-itemsets exist"
End If
End Function
Public Function GenL2(itemnum As Long, ByRef H2() As ItemNode, ByRef TotalH2Num As Long)
L2Num = 0
Dim temp() As ItemNode
Dim H2num As Long
TotalH2Num = 0
H2CountMax = 0
H2num = itemnum * (itemnum - 1) / 2 - 1
ReDim temp(0 To H2num)
For i = 0 To H2num
    TotalH2Num = TotalH2Num + H2(i).ItemStrCount
    If H2(i).ItemStrCount > H2CountMax Then
        H2CountMax = H2(i).ItemStrCount
    End If
    If (H2(i).ItemStrCount / TotalTransNum) >= SupportThreshold2 Then
        temp(L2Num).ItemStr = H2(i).ItemStr
        temp(L2Num).ItemStrCount = H2(i).ItemStrCount
        L2Num = L2Num + 1
    End If
Next i
If L2Num > 0 Then
    ReDim L2(0 To L2Num - 1)
    For j = 0 To L2Num - 1
        L2(j).ItemStr = temp(j).ItemStr
        L2(j).ItemStrCount = temp(j).ItemStrCount
    Next j
Else
    MsgBox "there no such frequent 2-itemsets exist"
End If
End Function

Public Function GenC2()