csamples.cls

Decision 算法

            End If
            
        End If
        
        rst.Filter = FirstFilter
        
        
        ClassValues.MoveNext
    
    Loop
    
    
    'Destroy and de reference objects
    rst.Close
    Set rst = Nothing
    
    
    If Count > 1 Then
    
        SameClass = False
        
    ElseIf Count = 1 Then
    
        SameClass = True
        
        mvarClass = Class_Candidate
        
    End If
    

End Function

Public Function MajorityClass(ByVal ClassName As String, ByVal ClassValues As ADODB.Recordset) As String
    'Returns the most common class in the samples
    
    Dim Count As Long
    Dim ClassCount As Long
    Dim Class_Value As String
    Dim Class_Candidate As String
    Dim FirstFilter As Variant
    Dim Filter As Variant
    Dim rst As ADODB.Recordset
    
    
    Set rst = Me.Clone(Me.DataSet)
    
    
    'The initital filter on the recordset
    FirstFilter = rst.Filter
    
    
    ClassValues.MoveFirst
    
    
    'Filter the records using each distinct value of the class
    'Count the number of records returned each time the sample is filtered
    'The Majority Class is the class with the highest number of records
    Do While ClassValues.EOF = False
    
        Class_Value = ClassValues.Fields("Attribute_Value")
        
        Filter = ClassName & " = '" & Class_Value & "'"
        
        rst.Filter = Filter
        
        If (ClassCount <= rst.RecordCount) Then
        
            Class_Candidate = Class_Value
            
            ClassCount = rst.RecordCount
            
        End If
        
        rst.Filter = FirstFilter
        
        
        ClassValues.MoveNext
    
    Loop

    
    
    'Destroy and de reference objects
    rst.Close
    Set rst = Nothing
    
    
    MajorityClass = Class_Candidate
    

End Function

Public Function Maximum_Gain(ByVal ClassName As String, ByVal ClassValues As ADODB.Recordset) As ADODB.Recordset
    'Returns the attribute with the maximum gain in the dataset
    
    Dim rstGain As ADODB.Recordset
    Dim AttributeValueInfo As Recordset
    Dim rst As ADODB.Recordset
    Dim AttributesList As ADODB.Recordset
    Dim UniqueAttributeValues As ADODB.Recordset
    Dim Filter As Variant
    Dim FirstFilter As Variant
    Dim AttributeInfo() As Variant
    Dim AttributeName As String
    Dim AttributeValue As String
    Dim ClassValue As String
    Dim NodeInfo As Double
    Dim Info As Double
    Dim Info_Average As Double
    Dim Frequency() As Long
    Dim Count_Class As Long
    Dim Count_Attribute As Long
    Dim Total_Class As Long
    Dim Total_Value As Long
        
        
    Set rstGain = New ADODB.Recordset

    With rstGain.Fields
        .Append "Attribute", adVarChar, 255
        .Append "Gain", adDouble
    End With
        
    'Open the recordset
    rstGain.Open
    
    
    'Create a new recordset
    Set AttributeValueInfo = New ADODB.Recordset
    
    With AttributeValueInfo.Fields
        .Append "AttributeName", adVarChar, 255
        .Append "AttributeValue", adVarChar, 255
        .Append "Total", adDouble
        .Append "Info", adDouble
    End With
    
    'Open the recordset
    AttributeValueInfo.Open
    
    
    Set rst = Me.Clone(Me.DataSet)
    
    'The existing filter on the recordset
    FirstFilter = rst.Filter
    
    
    'The information value at the Samples Node
    NodeInfo = Me.Info(ClassName, ClassValues)
        
        
    Set AttributesList = Me.Clone(Me.Attributes)
    
    
    AttributesList.MoveFirst
    
    
    Do While AttributesList.EOF = False
        
        
        AttributeName = AttributesList.Fields("Attribute")
        
        'The unique values of this attribute
        Set UniqueAttributeValues = DecisionTrees.GetUniqueValues(AttributeName)
        
        
        UniqueAttributeValues.MoveFirst
        
        
        Do While UniqueAttributeValues.EOF = False
            
            
            AttributeValue = UniqueAttributeValues.Fields("Attribute_Value")
          
          
            ClassValues.MoveFirst
          
          
            Do While ClassValues.EOF = False
          
                
                ClassValue = ClassValues.Fields("Attribute_Value")
                
                
                'Filter the records based on the attribute, attribute value and class and class value
                Filter = AttributeName & " = '" & AttributeValue & "'" & " and " & ClassName & " = '" & ClassValue & "'"
                                    
                rst.Filter = Filter
                
                
                ReDim Preserve Frequency(Count_Class)
                
                Frequency(Count_Class) = rst.RecordCount
                
                
                Total_Class = Total_Class + Frequency(Count_Class)
                
                
                Count_Class = Count_Class + 1
                
                
                ClassValues.MoveNext
                
                
                rst.Filter = FirstFilter
                
                
            Loop
            
            
            InfoValue = DecisionTrees.Entropy(Frequency)
                                    
          
            AttributeValueInfo.AddNew Array("AttributeName", "AttributeValue", "Total", "Info"), _
                                            Array(AttributeName, AttributeValue, Total_Class, InfoValue)
            
            
            Total_Value = Total_Value + Total_Class
            
            
            Count_Class = 0
            
            Total_Class = 0
            
            ReDim Frequency(Count_Class)
            
            
            UniqueAttributeValues.MoveNext
            
               
        Loop
        
        
        'Calculate the entropy value for the attribute
        AttributeValueInfo.MoveFirst
        
        Do While AttributeValueInfo.EOF = False
            
            
            ReDim Preserve AttributeInfo(Count_Attribute)
            
            
            Info_Average = (AttributeValueInfo.Fields("Total") * AttributeValueInfo.Fields("Info")) / Total_Value
            
            
            If IsEmpty(AttributeInfo(Count_Attribute)) Then
            
                AttributeInfo(Count_Attribute) = Array(AttributeName, Info_Average)
                
            Else
            
                AttributeInfo(Count_Attribute) = Array(AttributeName, Info_Average + AttributeInfo(Count_Attribute)(1))
                
            End If
             
            
            AttributeValueInfo.Delete
            
            AttributeValueInfo.MoveNext
            
            
        
        Loop
        
        
        'The Information Gain
        AttributeInfo(Count_Attribute)(1) = NodeInfo - AttributeInfo(Count_Attribute)(1)

        
        Total_Value = 0
        
        Count_Attribute = Count_Attribute + 1
                
        
        AttributesList.MoveNext
    
    
    Loop
    
        
    'The Maximum Information Gain
    For Count_Attribute = LBound(AttributeInfo) To UBound(AttributeInfo)
    
        If (rstGain.BOF = True) And (rstGain.EOF = True) Then
        
            rstGain.AddNew Array("Attribute", "Gain"), Array(AttributeInfo(Count_Attribute)(0), AttributeInfo(Count_Attribute)(1))
            
        Else
        
            If (rstGain.Fields("Gain") < AttributeInfo(Count_Attribute)(1)) Then
            
                With rstGain
                
                    .Update Array("Attribute", "Gain"), Array(AttributeInfo(Count_Attribute)(0), AttributeInfo(Count_Attribute)(1))
                    
                End With
                
            End If
            
        End If
    
    
    Next
    
    
    Set Maximum_Gain = rstGain


End Function