※ Elliott Pattern Helper Add In
Data clustering techniques are used in conjunction with radial basis function networks or fuzzy modeling primarily to determine initial locations for radial basis functions or fuzzy if-then rules.
They are validated on the basis of the following assumptions:
- Similar inputs to the target system to be modeled should produce similar outputs.
- These similar input-output pairs are bundled into clusters in the training data set.
One of the most common methods for data clustering is subtractive clustering proposed by S. L. Chiu.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Subtractive Clustering (by S. L. Chiu)
'' in Fuzzy Time Series beta1.
'' Authored by KyungSeog Kim, Copyright ⓒ 2012, all rights reserved.
'' May be redistributed for free,
'' but may not be sold without the author's explicit permission.
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const DEFAULT_RA = 0.5
Private Const DEFAULT_SF = 1.25
Private Const DEFAULT_AR = 0.5
Private Const DEFAULT_RR = 0.15
Private n As Integer 'the number of vectors
Private d As Integer 'the dimension of vectors
Private p() As Double 'potentials of all vectors
Private cp_ra As Double 'SC param Radius
Private cp_sf As Double 'SC param Squash Factor
Private cp_rr As Double 'SC param Reject Ratio
Private cp_ar As Double 'SC param Accept Ratio
Private ddots() As Double 'For performance, ddots are stored as they are computed
Function slc_sc(v, cp, b) 'v: 2-dim array, cp: SC params, b: normalized flag
Dim c_idx() As Integer 'id's of clusters found
Dim n_c As Integer 'number of clusters found
Dim p1 As Double
Dim skip As Boolean 'skip flag
Dim idx_k As Variant
Debug.Print "[MSubtractiveClustering.slc_sc]s, " & Timer
On Error GoTo EH_slc_sc:
n = UBound(v, 1)
d = UBound(v, 2)
If Not init_sc_params(cp) Then _
Err.Raise 9401, "MSubtractiveClustering.slc_sc", "Init SC params failed"
ReDim c_idx(1 To n)
If Not b Then v = shrink2D(v, 0, 1)
Call init_potentials(v)
skip = False
n_c = 1
p1 = WorksheetFunction.Max(p)
c_idx(n_c) = WorksheetFunction.Match(p1, p, 0)
Do While n_c < n
If Not skip Then
Call potential(v, c_idx(n_c), n_c + 1)
n_c = n_c + 1
Else
skip = False
End If
p_k = WorksheetFunction.Max(p)
idx_k = WorksheetFunction.Match(p_k, p, 0)
If p_k > cp_ar * p1 Then
c_idx(n_c) = idx_k
ElseIf p_k < cp_rr * p1 Then
n_c = n_c - 1
GoTo SkipLoop:
Else
Dim d_min As Double, distances() As Double
d_min = 0
ReDim distances(1 To n_c - 1)
For i = 1 To n_c - 1
ddot = 0
If idx_k < c_idx(i) Then
ddot = ddots(idx_k, c_idx(i))
Else
ddot = ddots(c_idx(i), idx_k)
End If
distances(i) = ddot
Next i
d_min = WorksheetFunction.Min(distances) ^ (1 / 2)
If (d_min / cp_ra + p_k / p1) >= 1 Then
c_idx(n_c) = idx_k
Else
p(idx_k) = 0
skip = True
End If
End If
Loop
SkipLoop:
ReDim Preserve c_idx(1 To n_c)
slc_sc = c_idx
Debug.Print "[MSubtractiveClustering.slc_sc]e, " & Timer
Exit Function
EH_slc_sc:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [.slc_sc]"
Err.Raise Err.Number, "slc_sc", Err.Description
End Function
Private Function init_sc_params(cp) As Boolean
init_sc_params = False
On Error GoTo EH_init_sc_params:
lb = LBound(cp)
If UBound(cp) - lb <> 3 Then _
Err.Raise 9402, "init_sc_params", "Invalid SC params"
cp_ra = cp(lb)
cp_sf = cp(lb + 1)
cp_ar = cp(lb + 2)
cp_rr = cp(lb + 3)
If cp_ra < 0 Or cp_ra > 1 Then cp_ra = DEFAULT_RA
If cp_sf < 1 Then cp_sf = DEFAULT_SF
If cp_ar < 0 Or cp_ar > 1 Then cp_ar = DEFAULT_AR
If cp_rr < 0 Or cp_rr > 1 Then cp_rr = DEFAULT_RR
init_sc_params = True
Exit Function
EH_init_sc_params:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [init_sc_params]"
End Function
Private Function init_potentials(v)
On Error GoTo EH_init_potentials:
Debug.Print "[MSubtractiveClustering.init_potentials]s, " & Timer
ReDim p(1 To n)
ReDim ddots(1 To n, 1 To n)
For i = 1 To n
Dim value As Double
value = 0
For k = 1 To i - 1
ddot = ddots(k, i)
value = value + Exp(-1 * (4 / cp_ra ^ 2) * ddot)
Next k
For k = i To n
ddot = 0
For j = 1 To d
ddot = ddot + (v(i, j) - v(k, j)) ^ 2
Next j
ddots(i, k) = ddot
value = value + Exp(-1 * (4 / cp_ra ^ 2) * ddot)
Next k
p(i) = value
Next i
Debug.Print "[MSubtractiveClustering.init_potentials]e, " & Timer
Exit Function
EH_init_potentials:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [init_potentials]"
Err.Raise 9403, "init_potentials", Err.Description
End Function
Private Function potential(v, k, c)
On Error GoTo EH_potential:
Debug.Print "[MSubtractiveClustering.potential]s, " & Timer
p_k = p(k) 'potential of vector at k
For i = 1 To n
p_i = p(i) 'potential of vector at i
ddot = 0
If i < k Then
ddot = ddots(i, k)
Else
ddot = ddots(k, i)
End If
p_i = p_i - p_k * Exp(-ddot * 4 / ((cp_sf ^ c * cp_ra) ^ 2))
p(i) = p_i
Next i
Debug.Print "[MSubtractiveClustering.potential]e, " & Timer
Exit Function
EH_potential:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [potential]"
Err.Raise 9403, "potential", Err.Description
End Function
Public Function shrink2D(v, l, u) 'normalize in all dimension, i.e., making hypercube
Dim c() As Double
On Error GoTo EH_shrink2D:
Debug.Print "[MSubtractiveClustering.shrink2D]s, " & Timer
lb = LBound(v, 1)
ub = UBound(v, 1)
ReDim c(lb To ub)
For j = LBound(v, 2) To UBound(v, 2)
If j = LBound(v, 2) Then
For i = lb To ub
c(i) = v(i, j)
Next i
End If
c = shrink(c, l, u)
If j < UBound(v, 2) Then
For i = lb To ub
v(i, j) = c(i)
c(i) = v(i, j + 1)
Next i
Else
For i = lb To ub
v(i, j) = c(i)
Next i
End If
Next j
shrink2D = v
Debug.Print "[MSubtractiveClustering.shrink2D]e, " & Timer
Exit Function
EH_shrink2D:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [shrink2D]"
Err.Raise 9403, "shrink2D", Err.Description
End Function
Public Function shrink(y As Variant, d1, d2)
Dim v() As Double
lb = LBound(y)
ub = UBound(y)
ReDim v(lb To ub)
mn = WorksheetFunction.Min(y)
mx = WorksheetFunction.Max(y)
For k = lb To ub
v(k) = d1 + (d2 - d1) * ((y(k) - mn) / (mx - mn))
Next k
shrink = v
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' Subtractive Clustering (by S. L. Chiu)
'' in Fuzzy Time Series beta1.
'' Authored by KyungSeog Kim, Copyright ⓒ 2012, all rights reserved.
'' May be redistributed for free,
'' but may not be sold without the author's explicit permission.
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const DEFAULT_RA = 0.5
Private Const DEFAULT_SF = 1.25
Private Const DEFAULT_AR = 0.5
Private Const DEFAULT_RR = 0.15
Private n As Integer 'the number of vectors
Private d As Integer 'the dimension of vectors
Private p() As Double 'potentials of all vectors
Private cp_ra As Double 'SC param Radius
Private cp_sf As Double 'SC param Squash Factor
Private cp_rr As Double 'SC param Reject Ratio
Private cp_ar As Double 'SC param Accept Ratio
Private ddots() As Double 'For performance, ddots are stored as they are computed
Function slc_sc(v, cp, b) 'v: 2-dim array, cp: SC params, b: normalized flag
Dim c_idx() As Integer 'id's of clusters found
Dim n_c As Integer 'number of clusters found
Dim p1 As Double
Dim skip As Boolean 'skip flag
Dim idx_k As Variant
Debug.Print "[MSubtractiveClustering.slc_sc]s, " & Timer
On Error GoTo EH_slc_sc:
n = UBound(v, 1)
d = UBound(v, 2)
If Not init_sc_params(cp) Then _
Err.Raise 9401, "MSubtractiveClustering.slc_sc", "Init SC params failed"
ReDim c_idx(1 To n)
If Not b Then v = shrink2D(v, 0, 1)
Call init_potentials(v)
skip = False
n_c = 1
p1 = WorksheetFunction.Max(p)
c_idx(n_c) = WorksheetFunction.Match(p1, p, 0)
Do While n_c < n
If Not skip Then
Call potential(v, c_idx(n_c), n_c + 1)
n_c = n_c + 1
Else
skip = False
End If
p_k = WorksheetFunction.Max(p)
idx_k = WorksheetFunction.Match(p_k, p, 0)
If p_k > cp_ar * p1 Then
c_idx(n_c) = idx_k
ElseIf p_k < cp_rr * p1 Then
n_c = n_c - 1
GoTo SkipLoop:
Else
Dim d_min As Double, distances() As Double
d_min = 0
ReDim distances(1 To n_c - 1)
For i = 1 To n_c - 1
ddot = 0
If idx_k < c_idx(i) Then
ddot = ddots(idx_k, c_idx(i))
Else
ddot = ddots(c_idx(i), idx_k)
End If
distances(i) = ddot
Next i
d_min = WorksheetFunction.Min(distances) ^ (1 / 2)
If (d_min / cp_ra + p_k / p1) >= 1 Then
c_idx(n_c) = idx_k
Else
p(idx_k) = 0
skip = True
End If
End If
Loop
SkipLoop:
ReDim Preserve c_idx(1 To n_c)
slc_sc = c_idx
Debug.Print "[MSubtractiveClustering.slc_sc]e, " & Timer
Exit Function
EH_slc_sc:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [.slc_sc]"
Err.Raise Err.Number, "slc_sc", Err.Description
End Function
Private Function init_sc_params(cp) As Boolean
init_sc_params = False
On Error GoTo EH_init_sc_params:
lb = LBound(cp)
If UBound(cp) - lb <> 3 Then _
Err.Raise 9402, "init_sc_params", "Invalid SC params"
cp_ra = cp(lb)
cp_sf = cp(lb + 1)
cp_ar = cp(lb + 2)
cp_rr = cp(lb + 3)
If cp_ra < 0 Or cp_ra > 1 Then cp_ra = DEFAULT_RA
If cp_sf < 1 Then cp_sf = DEFAULT_SF
If cp_ar < 0 Or cp_ar > 1 Then cp_ar = DEFAULT_AR
If cp_rr < 0 Or cp_rr > 1 Then cp_rr = DEFAULT_RR
init_sc_params = True
Exit Function
EH_init_sc_params:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [init_sc_params]"
End Function
Private Function init_potentials(v)
On Error GoTo EH_init_potentials:
Debug.Print "[MSubtractiveClustering.init_potentials]s, " & Timer
ReDim p(1 To n)
ReDim ddots(1 To n, 1 To n)
For i = 1 To n
Dim value As Double
value = 0
For k = 1 To i - 1
ddot = ddots(k, i)
value = value + Exp(-1 * (4 / cp_ra ^ 2) * ddot)
Next k
For k = i To n
ddot = 0
For j = 1 To d
ddot = ddot + (v(i, j) - v(k, j)) ^ 2
Next j
ddots(i, k) = ddot
value = value + Exp(-1 * (4 / cp_ra ^ 2) * ddot)
Next k
p(i) = value
Next i
Debug.Print "[MSubtractiveClustering.init_potentials]e, " & Timer
Exit Function
EH_init_potentials:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [init_potentials]"
Err.Raise 9403, "init_potentials", Err.Description
End Function
Private Function potential(v, k, c)
On Error GoTo EH_potential:
Debug.Print "[MSubtractiveClustering.potential]s, " & Timer
p_k = p(k) 'potential of vector at k
For i = 1 To n
p_i = p(i) 'potential of vector at i
ddot = 0
If i < k Then
ddot = ddots(i, k)
Else
ddot = ddots(k, i)
End If
p_i = p_i - p_k * Exp(-ddot * 4 / ((cp_sf ^ c * cp_ra) ^ 2))
p(i) = p_i
Next i
Debug.Print "[MSubtractiveClustering.potential]e, " & Timer
Exit Function
EH_potential:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [potential]"
Err.Raise 9403, "potential", Err.Description
End Function
Public Function shrink2D(v, l, u) 'normalize in all dimension, i.e., making hypercube
Dim c() As Double
On Error GoTo EH_shrink2D:
Debug.Print "[MSubtractiveClustering.shrink2D]s, " & Timer
lb = LBound(v, 1)
ub = UBound(v, 1)
ReDim c(lb To ub)
For j = LBound(v, 2) To UBound(v, 2)
If j = LBound(v, 2) Then
For i = lb To ub
c(i) = v(i, j)
Next i
End If
c = shrink(c, l, u)
If j < UBound(v, 2) Then
For i = lb To ub
v(i, j) = c(i)
c(i) = v(i, j + 1)
Next i
Else
For i = lb To ub
v(i, j) = c(i)
Next i
End If
Next j
shrink2D = v
Debug.Print "[MSubtractiveClustering.shrink2D]e, " & Timer
Exit Function
EH_shrink2D:
MsgBox "Error(" & Err.Number & ") " & Err.Description & " [shrink2D]"
Err.Raise 9403, "shrink2D", Err.Description
End Function
Public Function shrink(y As Variant, d1, d2)
Dim v() As Double
lb = LBound(y)
ub = UBound(y)
ReDim v(lb To ub)
mn = WorksheetFunction.Min(y)
mx = WorksheetFunction.Max(y)
For k = lb To ub
v(k) = d1 + (d2 - d1) * ((y(k) - mn) / (mx - mn))
Next k
shrink = v
End Function
댓글 없음:
댓글 쓰기