cdecisiontrees.cls

一个关于数据挖掘的决策树算法

    If DataAccessObject Is Nothing Then
        Set DataAccessObject = New cDataAccessObject
    End If
    
    
    'Make sure their is a valid connection
    If DataAccessObject.ConnectionObject Is Nothing Then
        
        Set DataAccessObject.ConnectionObject = New ADODB.Connection
                    
        'Store the Connection String Used
        ConnectionString = DataMiningServer.ConnectionStringUsed
        
        DataAccessObject.ConnectionObject.Open ConnectionString
        
    End If
        
    
    For CountFields = LBound(Attributes_Selected) To UBound(Attributes_Selected)
    
        FieldName = Attributes_Selected(CountFields)
        Count = Count + 1
        ReDim Preserve SQLString(Count)
        SQLString(Count) = "SELECT " & SQLString(Count)
        SQLString(Count) = SQLString(Count) & "'" & FieldName & "'" & " AS ATTRIBUTE, "
        SQLString(Count) = SQLString(Count) & FieldName & " AS ATTRIBUTE_VALUE, "
        SQLString(Count) = SQLString(Count) & Class_Selected & " AS CLASS, "
        SQLString(Count) = SQLString(Count) & "Count(" & Class_Selected & ") AS FREQUENCY "
        SQLString(Count) = SQLString(Count) & "FROM " & Table_Selected
        SQLString(Count) = SQLString(Count) & " GROUP BY " & FieldName & ", " & Class_Selected
    Next
    
    
    StaticCount = Count
    
    For Count = 1 To Count
        
        SelectString = SelectString & SQLString(Count)
        SelectString = SelectString & " UNION ALL "
    
    Next
    
    
    'Add the Class_Selected
    FieldName = Class_Selected
    SelectString = SelectString & "SELECT "
    SelectString = SelectString & "'" & FieldName & "'" & " AS ATTRIBUTE, "
    SelectString = SelectString & FieldName & " AS ATTRIBUTE_VALUE, "
    SelectString = SelectString & Class_Selected & " AS CLASS, "
    SelectString = SelectString & "Count(" & Class_Selected & ") AS FREQUENCY "
    SelectString = SelectString & "FROM " & Table_Selected
    SelectString = SelectString & " GROUP BY " & Class_Selected

    
    SelectString = Trim(SelectString)
     
    
    SelectString = SelectString & " ORDER BY ATTRIBUTE, ATTRIBUTE_VALUE"
    
   
    DataMiningServer.SQLStatementUsed = SelectString

    
    SourceString = "SELECT "
    
    For Count = LBound(Attributes_Selected) To UBound(Attributes_Selected)
        SourceString = SourceString & Attributes_Selected(Count) & ", "
    Next
    
    SourceString = Trim(SourceString)
        
    If Right(SourceString, 1) = "," Then
        SourceString = Mid(SourceString, 1, (Len(SourceString) - 1))
    End If
    
    Table_Selected = Trim(DataMiningServer.TableSelected)
    
    'Replace any bracketing of the table name
    If Right(Table_Selected, 1) = "]" Then
        Table_Selected = Mid(Table_Selected, 1, (Len(Table_Selected) - 1))
    End If
    
    If Left(Table_Selected, 1) = "[" Then
        Table_Selected = Mid(Table_Selected, 2, (Len(Table_Selected) - 1))
    End If
            
    SourceString = SourceString & ", " & Class_Selected
    SourceString = SourceString & " FROM " & Table_Selected
    
    
    DataMiningServer.SQLStatementUsed = SourceString
    
    
    'Enable index creation
    Set Me.DataSet_Second = New ADODB.Recordset
    Me.DataSet_Second.CursorLocation = adUseClient
    
    
    'Create one of the data sets used for the Decision Trees Algorithm
    DataAccessObject.ExecuteSQL SelectString, ConnectionString, DataAccessObject.ConnectionObject, _
                                    adUseClient, adOpenDynamic, adLockOptimistic, DataSet_Second
            
            
    'Create an Index on Attribute, Attriute_Value, Class_Selected Property
    'Set DataSet_Second = DataMiningServer.OptimizeField(DataSet_Second, "ATTRIBUTE", "ATTRIBUTE_VALUE", "CLASS")
    
    
    'Enable index creation
    Set Me.DataSet = New ADODB.Recordset
    Me.DataSet.CursorLocation = adUseClient

    
    'Retrieve all records for client side processing
    DataAccessObject.ExecuteSQL SourceString, ConnectionString, DataAccessObject.ConnectionObject, _
                                adUseClient, adOpenDynamic, adLockOptimistic, DataSet
                                
                                
    'Mine the data using the decision trees algorithm
    Set Root_Sample = New cSamples
    
    Set Root_Sample.DataSet = Me.DataSet
    
    
    'Create Unique Attribute Values
    Call Me.CreateUniqueAttributeValues
    
    'Create Unique Class Values
    Set Me.UniqueClassValues = Me.GetUniqueValues(Class_Selected)
    
    
    'The initial attribute list
    Set rst = New ADODB.Recordset

    With rst.Fields
        .Append "Attribute", adVarChar, 255, adFldKeyColumn
    End With
    
    
    'Open the recordset
    rst.Open
    
    'Optimize the fields for filtering
    Set rst = DataMiningServer.OptimizeField(rst, "Attribute")
    
    
    Me.UniqueAttributeValues.MoveFirst
    
    For Count = LBound(Attributes_Selected) To UBound(Attributes_Selected)
    
        rst.AddNew "Attribute", Attributes_Selected(Count)
        
    Next
    
    
    Set Root_Sample.Attributes = rst
    
    
    'Create Node properties for the root node
    Set Root_Node = New cNode
    Set Root_Node = Me.CreateNode("ROOT", Root_Node, NODE_TYPE.adRootNode)
    
    
    'Mine the data using the Decision Trees Data Mining Algorithm
    Call DecisionTreeMine(Root_Sample, Root_Node)
    
    
Exit_ErrorHandler:
    Exit Function


ErrorHandler:
    ErrorManager.ErrorHandler Err, "cDecisionTrees.CreateDecisionTree", vbCritical
    
    Resume Exit_ErrorHandler
    
    
End Function

Public Sub CreateUniqueAttributeValues()
On Error GoTo ErrorHandler
    'Creates a recordset with Unique Attribute Value Pairs
    
    
    Dim Count As Long
    Dim SQLString() As String
    Dim SelectString As String
    Dim AttributeName As String
    Dim ConnectionString As String
    
    
    'SELECT DISTINCT 'Outlook' AS ATTRIBUTE, Outlook AS ATTRIBUTE_VALUE FROM weather
    
    
    'A SQL String for selecting Unique Attribute and Value pairs
    For Count = LBound(Attributes_Selected) To UBound(Attributes_Selected)
        
        AttributeName = Attributes_Selected(Count)
        
        ReDim Preserve SQLString(Count)
        
        SQLString(Count) = "SELECT DISTINCT " & SQLString(Count) & "'" & AttributeName & "'" & " AS ATTRIBUTE, "
        SQLString(Count) = SQLString(Count) & AttributeName & " AS ATTRIBUTE_VALUE"
        SQLString(Count) = SQLString(Count) & " FROM " & Table_Selected
        SQLString(Count) = SQLString(Count) & " GROUP BY " & "'" & AttributeName & "'" & " , " & AttributeName
            
    Next
    
    
    For Count = LBound(SQLString) To UBound(SQLString)
    
        SelectString = SelectString & " " & SQLString(Count) & " UNION ALL "
    
    Next
    
    
    SelectString = SelectString & " SELECT DISTINCT " & "'" & Class_Selected & "'" & " AS ATTRIBUTE, "
    SelectString = SelectString & Class_Selected & " AS ATTRIBUTE_VALUE" & " FROM " & Table_Selected
    SelectString = SelectString & " GROUP BY " & "'" & Class_Selected & "'" & " , " & Class_Selected
    
    
    
    'Create the Data Access Object
    If DataAccessObject Is Nothing Then
        Set DataAccessObject = New cDataAccessObject
    End If
    
    
    'Make sure their is a valid connection
    If DataAccessObject.ConnectionObject Is Nothing Then
        
        Set DataAccessObject.ConnectionObject = New ADODB.Connection
                    
        'Store the Connection String Used
        ConnectionString = DataMiningServer.ConnectionStringUsed
        
        DataAccessObject.ConnectionObject.Open ConnectionString
        
    End If
    
    
    
    'Enable index creation
    Set mvarUniqueAttributeValues = New ADODB.Recordset
    mvarUniqueAttributeValues.CursorLocation = adUseClient
    
    
    'Create one of the data sets used for the Decision Trees Algorithm
    DataAccessObject.ExecuteSQL SelectString, ConnectionString, DataAccessObject.ConnectionObject, _
                                    adUseClient, adOpenDynamic, adLockOptimistic, mvarUniqueAttributeValues
        
   
    'Create an index on Attribute and Attribute_Value columns
    'Set mvarUniqueAttributeValues = DataMiningServer.OptimizeField(mvarUniqueAttributeValues, "ATTRIBUTE", "ATTRIBUTE_VALUE")
        
        
Exit_ErrorHandler:
    Exit Sub


ErrorHandler:
    ErrorManager.ErrorHandler Err, "cDecisionTrees.CreateUniqueAttributeValues", vbCritical
    
    Resume Exit_ErrorHandler
End Sub

Public Function CreateNode(ByVal NodeText As String, ByVal Parent As cNode, ByVal NodeType As NODE_TYPE) As cNode
    
    'Creates a Node object
    
    
    Dim strKey As String
    Dim Nodx As cNode
    
    
    Set Nodx = New cNode
      
    Set Nodx.NodeParent = Parent
    
    
    Nodx.NodeName = UCase(NodeText)
    
    Nodx.NodeIndex = DataMiningServer.NodeIndex
    
    Nodx.NodeType = NodeType
    
    
    'Add the node to the nodes collection
    cNodes.Add Nodx, CStr(Nodx.NodeIndex)
    
    
    Set CreateNode = Nodx
    
    
End Function