data.bas

在visual basic环境下

Attribute VB_Name = "Module1"
Public D(1 To 14) As DayType
Public D2() As DayType
Type DayType
    Outlook As OutlookEnum
    Temperature As TemperatureEnum
    Humidity As HumidityEnum
    Wind As WindEnum
    Scaled_Outlook As Double
    Scaled_Temperature As Double
    Scaled_Humidity As Double
    Scaled_Wind As Double
    Distance As Double
    Match As Long
End Type
Public Const nFeatures = 4
Public Output(1 To 14) As Boolean

Public Situation1 As DayType
Public Situation2 As DayType

Public Enum OutlookEnum
    Rain = 0
    Overcast = 1
    Sunny = 2
End Enum
Public Enum TemperatureEnum
    Cool = 0
    Mild = 1
    Hot = 2
End Enum
Public Enum HumidityEnum
    Normal = 0
    High = 1
End Enum
Public Enum WindEnum
    Weak = 0
    Strong = 1
End Enum

Sub SetD(Index As Integer, Outlook As OutlookEnum, Temperature As TemperatureEnum, Humidity As HumidityEnum, Wind As WindEnum, Optional Result As Integer = 1)
    Call SetDay(D(Index), Outlook, Temperature, Humidity, Wind)
    D(Index).Match = Index
    If Result = 0 Then
        Output(Index) = False
    ElseIf Result = -1 Then
        Output(Index) = True
    End If
End Sub

Sub SetDay(ByRef Day As DayType, Outlook As OutlookEnum, Temperature As TemperatureEnum, Humidity As HumidityEnum, Wind As WindEnum)
    Dim n As Integer
    Day.Outlook = Outlook
    Day.Temperature = Temperature
    Day.Humidity = Humidity
    Day.Wind = Wind
    Day.Scaled_Outlook = Outlook
    Day.Scaled_Temperature = Temperature
    Day.Scaled_Humidity = Humidity
    Day.Scaled_Wind = Wind
    Day.Match = 0
End Sub

Function ShowOutlook(Outlook As OutlookEnum) As String
    If Outlook = Sunny Then ShowOutlook = "Sunny"
    If Outlook = Overcast Then ShowOutlook = "Overcast"
    If Outlook = Rain Then ShowOutlook = "Rain"
End Function

Function ShowTemperature(Temperature As TemperatureEnum) As String
    If Temperature = Hot Then ShowTemperature = "Hot"
    If Temperature = Mild Then ShowTemperature = "Mild"
    If Temperature = Cool Then ShowTemperature = "Cool"
End Function

Function ShowHumidity(Humidity As HumidityEnum) As String
    If Humidity = High Then ShowHumidity = "High"
    If Humidity = Normal Then ShowHumidity = "Normal"
End Function

Function ShowWind(Wind As WindEnum) As String
    If Wind = Weak Then ShowWind = "Weak"
    If Wind = Strong Then ShowWind = "Strong"
End Function

Function ShowOutput(Result As Boolean) As String
    If Result Then ShowOutput = "Yes" Else ShowOutput = "No"
End Function

Function Distance(TrainEx1 As DayType, TrainEx2 As DayType) As Double
    If Form1.Check1.Value = 0 Then
        Distance = AbsDistance(TrainEx1, TrainEx2)
    Else
        Distance = EucDistance(TrainEx1, TrainEx2)
    End If
End Function

Function AbsDistance(TrainEx1 As DayType, TrainEx2 As DayType) As Double
    Dim n As Integer
    For n = 1 To nFeatures
        AbsDistance = AbsDistance + Abs(GetFeature(TrainEx1, n) - GetFeature(TrainEx2, n))
    Next n
End Function

Function EucDistance(TrainEx1 As DayType, TrainEx2 As DayType) As Double
    Dim n As Integer
    For n = 1 To nFeatures
        EucDistance = EucDistance + (GetFeature(TrainEx1, n) - GetFeature(TrainEx2, n)) ^ 2
    Next n
    EucDistance = (EucDistance) ^ 0.5
End Function

Function GetFeature(TrainEx As DayType, Index As Integer, Optional ReturnOriginal As Boolean) As Double
    If Form1.Check2.Value = 0 Or ReturnOriginal Then
        Select Case Index
        Case 1
            GetFeature = TrainEx.Outlook
        Case 2
            GetFeature = TrainEx.Temperature
        Case 3
            GetFeature = TrainEx.Humidity
        Case 4
            GetFeature = TrainEx.Wind
        End Select
    Else
        Select Case Index
        Case 1
            GetFeature = TrainEx.Scaled_Outlook
        Case 2
            GetFeature = TrainEx.Scaled_Temperature
        Case 3
            GetFeature = TrainEx.Scaled_Humidity
        Case 4
            GetFeature = TrainEx.Scaled_Wind
        End Select
    End If
End Function

Sub GetNearest(TrainEx As DayType, Nearest() As DayType, Number As Integer, ByRef InputList() As DayType, Optional Display As Boolean = True)
    ' Redimension array to fit number of nearest neighbors we want:
    ReDim Nearest(1 To Number)
    
    Dim Trainers As New Collection
    ' Create a full list of training examples:
    For n = LBound(InputList) To UBound(InputList)
        Trainers.Add n
    Next n
    
    If Display Then AddInfo "Finding nearest neighbors to:" & vbCrLf & "   " & DispDay(TrainEx) & vbCrLf
    ' Keep looking until we found as many nearest neighbors requested:
    For n = 1 To Number
        SmallestDistance = 0
        SmallestIndex = 0
        For i = 1 To Trainers.Count
            InputList(Trainers(i)).Distance = Distance(TrainEx, InputList(Trainers(i)))
            If InputList(Trainers(i)).Distance < SmallestDistance Or SmallestDistance = 0 Then
                SmallestDistance = InputList(Trainers(i)).Distance
                SmallestIndex = i
            End If
        Next i
        If Display Then
            ' Highlight the nearest neighbors:
            If n - 1 >= Form1.Highlighter.Count Then
                Load Form1.Highlighter(n - 1)
            End If
            Form1.Highlighter(n - 1).Move 3, (Trainers(SmallestIndex) * 18) + 6, Form1.Table.Width - 8, 18
            Form1.Highlighter(n - 1).Visible = True
            AddInfo "Neighbor #" & n & ":" & vbCrLf & "   Day #" & Trainers(SmallestIndex) & ": " & DispDay(InputList(Trainers(SmallestIndex)))
            AddInfo "   Output: " & ShowOutput(Output(Trainers(SmallestIndex))) & " = " & Abs(Output(Trainers(SmallestIndex)))
        End If
        Nearest(n) = InputList(Trainers(SmallestIndex))
        Trainers.Remove SmallestIndex
    Next n
End Sub

Function DispDay(TrainEx As DayType) As String
    DispDay = ShowOutlook(TrainEx.Outlook) & ", " & ShowTemperature(TrainEx.Temperature) & ", " & ShowHumidity(TrainEx.Humidity) & ", " & ShowWind(TrainEx.Wind)
End Function

Sub AddInfo(Text As String)
    Form1.Info.Text = IIf(Form1.Info.Text <> "", Form1.Info.Text & vbCrLf, "") & Text
    Form1.Info.SelStart = Len(Form1.Info.Text)
End Sub

Function GetResult(TrainEx As DayType, ByRef InputList() As DayType, Neighbors As Integer, Optional Display As Boolean = True) As Double
    Dim Nearest() As DayType
    Form1.Info.Text = ""
    Call GetNearest(TrainEx, Nearest(), Neighbors, InputList, Display)
    If Display Then AddInfo vbCrLf & "Results highlighted in table."
    Msg = ""
    Ms2 = ""
    Result = 0
    For n = LBound(Nearest) To UBound(Nearest)
        Msg = Msg & vbCrLf & Nearest(n).Distance
        Ms2 = IIf(Ms2 <> "", Ms2 & " + ", "") & Abs(Output(Nearest(n).Match))
        Result = Result + Abs(Output(Nearest(n).Match))
    Next n
    If Display Then
        AddInfo vbCrLf & "Total number of nearest neighbors:" & vbCrLf & "   " & Neighbors
        AddInfo "Sum of output of nearest neighbors is:" & vbCrLf & "   " & Ms2 & " = " & Result
        AddInfo vbCrLf & "Calculated result:" & vbCrLf & "   " & Result & " / " & Neighbors & " = " & Result / Neighbors
    End If
    
    If Display Then
        If Round(Result / Neighbors) = 0 Then
            AddInfo vbCrLf & "PlayTennis = No"
            GetResult = 0
        ElseIf Round(Result / Neighbors) = 1 Then
            AddInfo vbCrLf & "PlayTennis = Yes"
            GetResult = 1
        Else
            AddInfo vbCrLf & "PlayTennis = Unknown!"
            GetResult = -1
        End If
    Else
        GetResult = Result / Neighbors
    End If
End Function

Function GetMean(Index As Integer, ByRef InputList() As DayType) As Double
    For n = LBound(InputList) To UBound(InputList)
        GetMean = GetMean + GetFeature(InputList(n), Index, True)
    Next n
    GetMean = GetMean / (UBound(InputList) - LBound(InputList) + 1)
End Function

Function GetSigma(Index As Integer, ByRef InputList() As DayType) As Double
    For n = LBound(InputList) To UBound(InputList)
        GetSigma = GetSigma + (GetFeature(InputList(n), Index, True) - GetMean(Index, InputList)) ^ 2
    Next n
    GetSigma = (GetSigma / (UBound(InputList) - LBound(InputList) + 1)) ^ 0.5
End Function

Sub CreateScale(Index As Integer, ByRef InputList() As DayType)
    Dim n As Integer
    
    For n = 1 To nFeatures
        Select Case n
        Case 1
            InputList(Index).Scaled_Outlook = (InputList(Index).Outlook - GetMean(n, InputList)) / GetSigma(n, InputList)
        Case 2
            InputList(Index).Scaled_Temperature = (InputList(Index).Temperature - GetMean(n, InputList)) / GetSigma(n, InputList)
        Case 3
            InputList(Index).Scaled_Humidity = (InputList(Index).Humidity - GetMean(n, InputList)) / GetSigma(n, InputList)
        Case 4
            InputList(Index).Scaled_Wind = (InputList(Index).Wind - GetMean(n, InputList)) / GetSigma(n, InputList)
        End Select
    Next n
End Sub