cdecisiontrees.cls

Decision 算法

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cDecisionTrees"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'The attributes selected
Public Attributes_Selected As Variant

'The Class Selected
Public Class_Selected As String

'The selected table
Public Table_Selected As String


Private mvarUniqueAttributeValues As ADODB.Recordset
Private mvarDataSet As ADODB.Recordset
Private mvarMajorityClass As String
Private mvarDataSet_Second As ADODB.Recordset
Private mvarUniqueClassValues As ADODB.Recordset

Public Property Set UniqueClassValues(ByVal vData As ADODB.Recordset)
    Set mvarUniqueClassValues = vData
End Property

Public Property Get UniqueClassValues() As ADODB.Recordset
    Set UniqueClassValues = mvarUniqueClassValues
End Property

Public Property Set DataSet_Second(ByVal vData As ADODB.Recordset)
    Set mvarDataSet_Second = vData
End Property

Public Property Get DataSet_Second() As ADODB.Recordset
    Set DataSet_Second = mvarDataSet_Second
End Property

Public Property Let MajorityClass(ByVal vData As String)
Attribute MajorityClass.VB_Description = "The most common class in the data set or original sample at the root node of the decision tree"
    'The most common class in the data set or original sample at the root node of the decision tree
    mvarMajorityClass = vData
End Property

Public Property Get MajorityClass() As String
    'The most common class in the data set or original sample at the root node of the decision tree
    MajorityClass = mvarMajorityClass
End Property

Public Property Get UniqueAttributeValues() As ADODB.Recordset
    Set UniqueAttributeValues = mvarUniqueAttributeValues
End Property

Public Property Set DataSet(ByVal vData As ADODB.Recordset)
'The ADODB Recordset of the set of samples in the recordset
    Set mvarDataSet = vData
End Property

Public Property Get DataSet() As ADODB.Recordset
'The ADODB Recordset of the set of samples in the recordset
    Set DataSet = mvarDataSet
End Property

Public Function CopySamples(ByVal Sample As cSamples) As cSamples
    'Creates a copy of cSamples
    
    Dim NewSample As cSamples
    
    
    Set NewSample = Sample
    
    Set CopySamples = NewSample
    
    Set NewSample = Nothing
    
    
End Function

Public Function GetUniqueValues(ByVal AttributeName As String) As ADODB.Recordset
    'The unique values of an attribute
        
    Dim rst As ADODB.Recordset
            
        
    Set rst = UniqueAttributeValues.Clone
    
    
    rst.Filter = "Attribute = '" & AttributeName & "'"
    
    
    Set GetUniqueValues = rst
    

End Function

Public Function DecisionTreeMine(Samples As cSamples, ByVal NodeX As cNode) As colNodes
On Error GoTo ErrorHandler
'Creates a decision tree


Dim AttributeValues As ADODB.Recordset
Dim SamplePartition As cSamples
Dim NodeY As cNode
Dim NodeZ As cNode
Dim Class As String
Dim SplitAttribute As String
Dim UniqueValue As String



'1.     If Samples are all of the same class then return the class
If Samples.SameClass(Class_Selected, Me.UniqueClassValues) = True Then

        
    Class = Samples.Class
    
    
    Set NodeY = Me.CreateNode(Class, NodeX, NODE_TYPE.adLeafNode)
    
    
'2.     If the attribute list is empty then return the majority class in the samples
ElseIf Samples.AttributesCount = 0 Then

    
    Class = Samples.MajorityClass(Class_Selected, Me.UniqueClassValues)
    
    
    Set NodeY = Me.CreateNode(Class, NodeX, NODE_TYPE.adLeafNode)
    
    
'4.     Select the attribute in the attribute list with the Highest Information Gain
Else

        
    SplitAttribute = Samples.Maximum_Gain(Class_Selected, UniqueClassValues).Fields("Attribute")
    
    
    Set NodeY = Me.CreateNode(SplitAttribute, NodeX, NODE_TYPE.adAttributeNode)

        
    Set AttributeValues = Me.GetUniqueValues(SplitAttribute)
    
    
    AttributeValues.MoveFirst
    
    
'5.     For each distinct value of the attribute, partition the sample
    Do While AttributeValues.EOF = False
    
    
        UniqueValue = AttributeValues.Fields("ATTRIBUTE_VALUE")
        
        
        Set SamplePartition = Samples.Partition(SplitAttribute, UniqueValue, Samples)
        
        
        'Create a Node for each distinct value of the attribute selected
        Set NodeZ = Me.CreateNode(UniqueValue, NodeY, NODE_TYPE.adValueNode)

        
        
        If (SamplePartition.RecordCount = 0) Then
        
        
            Class = Me.MajorityClass
            
            
            Set NodeY = Me.CreateNode(Class, NodeZ, NODE_TYPE.adLeafNode)

            
        Else
        

            Call DecisionTreeMine(SamplePartition, NodeZ)
            
        
        End If
            
            
        AttributeValues.MoveNext
        
        
    Loop
            
    
End If


Exit_ErrorHandler:
    Exit Function


ErrorHandler:
    ErrorManager.ErrorHandler Err, "cDecisionTrees.DecisionTreeMine", vbCritical
    
    Resume Exit_ErrorHandler


End Function

Public Function Entropy(Values() As Long) As Double

        
    Dim Count As Long
    Dim Value As Double
    Dim Info As Double
    Dim Total As Double
    
        
    For Count = LBound(Values) To UBound(Values)
    
        Total = Total + Values(Count)
        
        If (Values(Count) = 0) Then
        
            Entropy = 0
            
            Exit Function
            
        End If
        
    Next
    
    
    For Count = LBound(Values) To UBound(Values)
        
        Value = Values(Count)
        Info = Info + (-Value) * (LogN(Value, 2))
        
    Next
    
    
    Info = Info + (Total) * (LogN(Total, 2))
    
    
    Info = Info / Total
    
    
    Entropy = Info

    
End Function

Private Function LogN(x As Double, BaseN As Double) As Double

  LogN = Log(x) / Log(BaseN)
  
End Function

Private Sub Class_Initialize()
    
    'The Attributes Selected
    Attributes_Selected = DataMiningServer.AttributesSelected
    
    'The Attribute used for Class_Selectedification
    Class_Selected = DataMiningServer.ClassSelected
    
    'The selected table
    Table_Selected = DataMiningServer.TableSelected
    
    If Right(Table_Selected, 1) = "]" Then
        Table_Selected = Left(Table_Selected, Len(Table_Selected) - 1)
    End If
    
    If Left(Table_Selected, 1) = "[" Then
        Table_Selected = Right(Table_Selected, Len(Table_Selected) - 1)
    End If
    
        
End Sub
Public Function CreateDecisionTree() As colNodes
On Error GoTo ErrorHandler

    
    Dim Count As Long
    Dim StaticCount As Long
    Dim SQLString() As String
    Dim SourceString As String
    Dim SelectString As String
    Dim FieldName As String
    Dim ConnectionString As String
    Dim Root_Sample As cSamples
    Dim Root_Node As cNode
    Dim rst As ADODB.Recordset
            
    
    'Create the Data Access Object