csamples.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 = "cSamples"
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"

Private mvarClass As String
Private mvarDataSet As ADODB.Recordset
Private mvarAttributes As ADODB.Recordset
Private mvarRecordCount As Long
Private mvarAttributesCount As Long
Private mvarUniqueClassValues As Boolean

Public Property Get UniqueClassValues() As Boolean
Attribute UniqueClassValues.VB_Description = "Returns True if all the samples in the data set have the same class value and False if not"
    'Returns True if all the samples in the data set have the
    'same class value and False if not
    
    
    UniqueClassValues = mvarUniqueClassValues
    
End Property

Public Property Get AttributesCount() As Long
Attribute AttributesCount.VB_Description = "The number of attributes in the attributes list of the samples"
    mvarAttributesCount = Attributes.RecordCount
    AttributesCount = mvarAttributesCount
End Property

Public Property Get RecordCount() As Long
Attribute RecordCount.VB_Description = "The number of samples or records  in the data set"
    mvarRecordCount = Me.DataSet.RecordCount
    RecordCount = mvarRecordCount
End Property

Public Property Set Attributes(ByVal vData As ADODB.Recordset)
Attribute Attributes.VB_Description = "The list of attributes for a sample"
    Set mvarAttributes = vData
End Property

Public Property Get Attributes() As ADODB.Recordset
    Set Attributes = mvarAttributes
End Property

Public Property Set DataSet(ByVal vData As ADODB.Recordset)
Attribute DataSet.VB_Description = "The ADODB Recordset of the set of samples"
'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 Property Get Class() As String
    Class = mvarClass
End Property
Public Function Filter(ByVal rstSource As ADODB.Recordset, ByVal varFilter As Variant) As ADODB.Recordset
    'Applies a filter to a recordset and preserves the value of the Filter property of the recordset
    
    
    Dim rsFiltered As New ADODB.Recordset
    Dim objSm As New Stream


    'Save the recordset to a stream object in XML format
    rstSource.Save objSm, adPersistXML
       
    
    rsFiltered.Open objSm
    
    
    rsFiltered.Filter = varFilter
    
    
    objSm.Close
    Set objSm = Nothing
    
    
    Set Filter = rsFiltered
    
    
End Function

Public Function FirstFilter(ByVal rstSource As ADODB.Recordset, ByVal varFilter As Variant) As ADODB.Recordset
    'Applies a filter to a recordset and removes the value of the Filter property of the recordset
    
    
    Dim FirstFilter As ADODB.Recordset
    Dim rsFiltered As New ADODB.Recordset
    Dim objSm As New Stream


    ' apply a filter
    If (rstSource.Filter = 0) Then
        
        rstSource.Filter = varFilter
        
        ' Save the recordset to a stream object in XML format
        rstSource.Save objSm, adPersistXML

    Else
    
        ' Save the recordset to a stream object in XML format
        rstSource.Save objSm, adPersistXML
        
        Set FirstFilter = New ADODB.Recordset
        
        FirstFilter.Open objSm
        
        FirstFilter.Filter = varFilter
        
        FirstFilter.Save objSm, adPersistXML
        
            
        FirstFilter.Close
        Set FirstFilter = Nothing
    
    End If
    
    
    rsFiltered.Open objSm
    
    
    objSm.Close
    Set objSm = Nothing
    
    
    Set FirstFilter = rsFiltered
    
    
End Function

Public Function Clone(ByVal rstSource As ADODB.Recordset) As ADODB.Recordset
    'Creates a copy of a recordset using MDAC 2.5 ADO Stream object and XML
    
    
    Dim rstCopy As New ADODB.Recordset
    Dim objSm As New Stream
    
    
    ' Save the recordset to a stream object in XML format
    rstSource.Save objSm, adPersistXML
    
    
    rstCopy.Open objSm
    
    
    objSm.Close
    Set objSm = Nothing
    
    
    Set Clone = rstCopy
        
    
End Function

Public Function Info(ByVal ClassName As String, ByVal ClassValues As ADODB.Recordset) As Double
    'The information value at a node corresponding to the sample
    
    
    Dim rst As ADODB.Recordset
    Dim FirstFilter As Variant
    Dim Filter As Variant
    Dim ClassValue As String
    Dim Frequency() As Long
    Dim Count As Long
    
    
    Set rst = Me.Clone(Me.DataSet)
    
    
    FirstFilter = rst.Filter
    
    
    ClassValues.MoveFirst
    
        
    Do While ClassValues.EOF = False
    
        
        ClassValue = ClassValues.Fields("Attribute_Value")
        
    
         Filter = ClassName & " = '" & ClassValue & "'"
         
         
         rst.Filter = Filter
         
         
         ReDim Preserve Frequency(Count)
         
         
         Frequency(Count) = rst.RecordCount
         
         
         Count = Count + 1
         
         
         rst.Filter = FirstFilter
                  
         
         ClassValues.MoveNext
        
        
    Loop
        
    
    'Calculate the information value at the Node
    Info = DecisionTrees.Entropy(Frequency)
    
    
End Function
Public Function Partition(ByVal Attribute_Name As String, ByVal Attribute_Value As String, _
                            ByVal Sample As cSamples) As cSamples
    'Partitions the data set based on an attribute and a distinct value of the attribute
    
    
    Dim PartitionSet As New cSamples
    Dim FirstFilter(1 To 2) As Variant
    Dim Filter As Variant
        
    
    'The existing filters on the recordsets
    FirstFilter(1) = Sample.DataSet.Filter
    
    FirstFilter(2) = Sample.Attributes.Filter
    
        
    Filter = Attribute_Name & " = '" & Attribute_Value & "'"
    
        
    Set PartitionSet.DataSet = Me.Filter(Sample.DataSet, Filter)
    
        
    Sample.Attributes.MoveFirst
    
    
    Set PartitionSet.Attributes = Me.Filter(Sample.Attributes, "Attribute = '" & Attribute_Name & "'")
    
    
    Do While PartitionSet.Attributes.EOF = False
    
        PartitionSet.Attributes.Delete
        
        PartitionSet.Attributes.MoveNext
        
    Loop
    
    
    'Apply the pre-existing filters
    Sample.DataSet.Filter = FirstFilter(1)
    
    Sample.Attributes.Filter = FirstFilter(2)
    
    PartitionSet.Attributes.Filter = FirstFilter(2)
 
    
    Set Partition = PartitionSet
    

End Function

Public Function SameClass(ByVal ClassName As String, ByVal ClassValues As ADODB.Recordset) As Boolean
Attribute SameClass.VB_Description = "Indicates if the samples are all of the same class"
    'Returns True if all the samples have the same class
    
    Dim Count 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
    
    
    Do While ClassValues.EOF = False
    
        Class_Value = ClassValues.Fields("Attribute_Value")
        
        Filter = ClassName & " = '" & Class_Value & "'"
        
        rst.Filter = Filter
        
        If (rst.RecordCount > 0) Then
        
            Count = Count + 1
            
            If Count = 1 Then
            
                Class_Candidate = Class_Value