initial.bas

vb apriori algorithm

C2TotalNum = (L1Num - 1) * L1Num / 2 - 1
ReDim C2(0 To (C2TotalNum))
ReDim temp(0 To (C2TotalNum))
C2Num = 0
''''''''''''此处需要改变一下 用L1Num 可以减少循环次数
For i = 0 To L1Num - 1
        For j = i + 1 To L1Num - 1
            C2(C2Num).ItemStr = L1(i).ItemStr + L1(j).ItemStr
            C2Num = C2Num + 1
        Next j
Next i

End Function
Public Function StrDecomposeOld(Str As String, n As Long)
Dim mystring, mychar As String
Dim beginpos, endpos, pos, strlen, Num As Long
Dim INum As Long
ReDim ItemStr(0 To n - 1)
mychar = "I"
beginpos = 1 + 1
endpos = 1
mystring = Str
strlen = Len(mystring)
INum = 0
Do While (InStr(beginpos, mystring, mychar, vbTextCompare))
    pos = InStr(beginpos, mystring, mychar, vbTextCompare)
    Num = Val(Mid(mystring, beginpos, (pos - beginpos)))
    ItemStr(INum) = "I" + CStr(Num)
    beginpos = pos + 1
    INum = INum + 1
Loop
    Num = Val(Mid(mystring, beginpos))
    ItemStr(INum) = "I" + CStr(Num)
End Function
Public Function StrDecompose(ItemStr As String, n As Long, itemnum As Long, ByRef L1Temp() As ItemNode)
'***************************************************************************************************
''此函数分解每条交易记录里面的字符串，将分解的结果用ItemStr（）数组保存。如“I001I008I013I124”则ItemStr（0）=001，ItemStr（1）=008.....
''并用L1Temp(a).ItemStrCount的计数+1
''其中为交易字符串，n为字符串中包含item的个数
''此处为 ItemStr的长度/4因为 交易中的Item以I000~I999表示
''
'***************************************************************************************************
Dim i, a, BeginPoint As Long
ReDim ItemStr(0 To n - 1)
ReDim ItemCount(0 To itemnum - 1)
For i = 0 To n - 1
    BeginPoint = (i) * 4 + 2
    ItemStr(i) = Mid(ItemStr, BeginPoint, 3)
    a = Val(ItemStr(i))
    ItemCount(a) = ItemCount(a) + 1
    L1Temp(a).ItemStr = "I" + ItemStr(i)
    L1Temp(a).ItemStrCount = L1Temp(a).ItemStrCount + 1
Next i
End Function
Public Function SubSet(Str1 As String, Str2 As String, C2Turn As Long)
StrDecompose Str2, 2
'C2Turn = 34
Dim i As Long
Dim pos As Long
For i = 0 To 1
    If InStr(1, Str1, ItemStr(i), vbTextCompare) Then
        pos = InStr(1, Str1, ItemStr(i), vbTextCompare)
        If (Mid(Str1, pos + Len(ItemStr(i)), 1) = "I" Or Mid(Str1, pos + Len(ItemStr(i)), 1) = "") Then
            If i = 1 Then
                C2(C2Turn).ItemStrCount = C2(C2Turn).ItemStrCount + 1
            End If
        End If
        Exit Function
    End If
Next i
End Function
Public Function JudgeLargeItemSet()
L2Num = 0
For i = 0 To C2TotalNum
    If (C2(i).ItemStrCount / TotalTransNum) >= SupportThreshold Then
        temp(L2Num).ItemStr = C2(i).ItemStr
        temp(L2Num).ItemStrCount = C2(i).ItemStrCount
        L2Num = L2Num + 1
    Else
        'L1(j) = ""
    End If
Next i
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

End Function
Public Function GenrndItem1920()
'***************************************************************************************************
''此函数产生Item数量为19和20的交易纪录 因为1000条记录时正态分布19，20 交易记录数量为0此处以50代替零
''其余和GenRndItem()函数类似
''不过此函数产生较早 已经弃用
''
'***************************************************************************************************
Dim i, j, k, l, m As Long
Dim a As Long
ItemUpperBound = 100
itemlowerbound = 1
normaldistribut_TNum(19) = 50
normaldistribut_TNum(20) = 50
Gendata_rs.MoveLast
For i = 19 To 20
    'ReDim ItemNum(normaldistribut_TNum(i)) As long
    For j = 1 To normaldistribut_TNum(i)
        ReDim itemnum(1 To 2)
        ItemString = ""
        For k = 1 To 2
TestSame:   Randomize
            itemnum(k) = Int(ItemUpperBound - itemlowerbound + 1) * Rnd
            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 2
            ItemString = ItemString + "I" + CStr(itemnum(m))
        Next m
            Gendata_rs.AddNew
            Gendata_rs!item = ItemString
            Gendata_rs.Update
            Gendata_rs.MoveNext
    Next j
Next i
End Function
Public Function RndGenItem(AddNum As Long, ItemUpperBound As Long)
'***************************************************************************************************
''此函数产生AddNum数量的 交易条目 每个条目含有40个item
''其余和GenRndItem()函数类似
''
''
'***************************************************************************************************
Dim i, j, k, l, m As Long
Dim a As Long
    For j = 1 To AddNum
        ReDim itemnum(1 To 40)
        ItemString = ""
        For k = 1 To 40
TestSame:   Randomize
            itemnum(k) = Int(ItemUpperBound) * Rnd
            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
            Call QuickSort(itemnum(), 1, UBound(itemnum))
        For m = 1 To 40
            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
End Function
Public Function TransGen2Item(Str1 As String, n As Long)
'***************************************************************************************************
''此函数产生每条交易纪录中的 2-itemsets
''并调用TransH2Gen 在H2中增加相应的地址即相应2-itemsets的计数 Str1为每条纪录的字符串 n为字符串中包含item的个数
''此处为 Str1的长度/4因为 交易中的Item以I000~I999表示，ItemStr(i)，ItemStr(j)为Str1中分解出来的 数字量
''如“I001I008I013I124”则ItemStr（0）=001，ItemStr（1）=008.........
'***************************************************************************************************
Dim TransTemp2ItemStr As String
For i = 0 To n - 1
    For j = i + 1 To n - 1
        TransTemp2ItemStr = "I" + ItemStr(i) + "I" + ItemStr(j)
        TransH2Gen ItemUpperBound, Val(ItemStr(i)), Val(ItemStr(j)), TransTemp2ItemStr
    Next j
Next i
End Function
Public Function TransH2Gen(itemnum As Long, firstnum As Long, secondnum As Long, NodeStr As String)
'***************************************************************************************************
''此函数为任意一个2-itemset 在H2数组中确定其在数组中的位置并计数
''如总的item的数量为1~100 则可以知道I006I008在H2中的地址=99+98+97+96+95+（008-006）-1 即程序中循环部分
''此处H2采用直接定址的方法用数组代替了Hash表结构
''itemnum=ItemUpperBound为Item的总的个数，如“I001I008”则firstnum=001，secondnum=008，NodeStr则为“I001I008”
'***************************************************************************************************
Dim i, H2num As Long
H2num = 0
If firstnum = 1 Then
Else
    For i = 1 To firstnum - 1
        H2num = H2num + (itemnum - i)
    Next i
End If
H2num = H2num + (secondnum - firstnum) - 1
H2(H2num).ItemStr = NodeStr
H2(H2num).ItemStrCount = H2(H2num).ItemStrCount + 1
End Function
Public Function GenRndNum(MaxTimeNum As Integer, MinTimeNum As Integer, RowArrayLen As Integer) As Long
'***************************************************************************************************
''此函数用于生长具有不同倍频的随机数，如1~99 用Rnd产生 1，2，3。。。。。。99具有相同的频率 如果希望其中的某些数字希
''望具有不同的频率 如2，3，4产生的频率为其他数字的2倍，23，25，36为其他数字产生频率的3倍，50，67，89为4倍频率等等，
''此处需要一个预先定义的频率数组存放这些需要倍频的数字 如FrqNumArray(1 to （MaxTimeNum-MinTimeNum+1）*RowArrayLen)
''其中MinTimeNum 多为2。 RowArrayLen为各倍频中 数字数量 为简化起见采用同长度
'***************************************************************************************************
Dim i, j, k, l As Integer
Dim Num() As Long           '随机生成数数组数量为MaxTimeNum
Dim ReturnNum() As Long     '具有最大MaxFrq倍频的随机数 数组 最大长度为MaxTimeNum
Dim NumFrq() As Integer     '每个随机数在产生的倍频数组 长度为MaxTimeNum
    ReDim Num(1 To MaxTimeNum)
    ReDim ReturnNum(1 To MaxTimeNum)
    ReDim NumFrq(1 To MaxTimeNum)
Dim NonZero As Long          '具有MaxFrq倍频的随机数个数
    NonZero = 1
Dim SelectNum As Integer     'MaxFrq非零时选择那个随机数作为输出数
Dim MaxFrq As Integer
MaxFrq = 0
For i = 1 To MaxTimeNum
GenAgain:    Randomize
    Num(i) = ItemUpperBound * Rnd
    If Num(i) = 0 Or Num(i) = ItemUpperBound Then   '不产生0或者ItemUpperBound如1000
        GoTo GenAgain
    End If
Next i
For j = 1 To MaxTimeNum
    Dim kLow As Integer
    If j = 1 Then
        kLow = 0
    Else
        kLow = ((j - MinTimeNum) * RowArrayLen)
    End If
    For k = kLow To ((MaxTimeNum - MinTimeNum + 1) * RowArrayLen - 1) '不能产生如Num(j),NumFrq(j)=3
                                                                    '这样的数据必须 j>=NumFrq(j)=倍频
       If Num(j) = FrqNumArray(k) Then
            NumFrq(j) = Int(k / RowArrayLen) + MinTimeNum
            If NumFrq(j) > MaxFrq Then
                MaxFrq = NumFrq(j)
            End If
            Exit For
       End If
    Next k
Next j
If MaxFrq = 0 Then
    GenRndNum = Num(1)
Else                                                                 '产生备选随机数
    For l = 1 To MaxTimeNum
        If NumFrq(l) = MaxFrq Then
            ReturnNum(NonZero) = Num(l)
            NonZero = NonZero + 1
        End If
    Next l
selectagain:    Randomize                                            '具体选择那个数据作为生成的随机数
    SelectNum = (NonZero - 1) * Rnd
    If SelectNum > 0 And SelectNum < NonZero Then
        GenRndNum = ReturnNum(SelectNum)
    Else
        GoTo selectagain
    End If
End If
End Function