generalregressor.cls

GIS二次开发,主要是结合AE和VB做的实验开原代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "GeneralRegressor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' Copyright 1995-2005 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]

'This code is (slightly) adapted from the following:
'http://www.codeguru.com/vb/articles/2296.shtml
'Written by Frank Schindler, <[e-mail]>
'June, 2002

Option Explicit

Private Const MaxO& = 5
Private m_GlobalO As Long '"Ordnung" = degree of the polynom expected
Private m_Finished As Boolean

Private m_SumX(0 To 2 * MaxO) As Double
Private m_SumYX(0 To MaxO) As Double
Private m_M(0 To MaxO, 0 To MaxO + 1)  As Double
Private m_C(0 To MaxO) As Double 'coefficients in: Y = C(0)*X^0 + C(1)*X^1 + C(2)*X^2 + ...

Public Property Let Degree(NewVal As Long)
  If NewVal < 0 Or MaxO < NewVal Then
    Err.Raise 6000, "RegressionObject", NewVal & " is an invalid property value! Use 0<= Degree <= " & MaxO
    Exit Property
  End If
  Init
  m_GlobalO = NewVal
End Property

Public Property Get Degree() As Long
  Degree = m_GlobalO
End Property

Public Property Get Coeff(Exponent As Long) As Double
  Dim Ex As Long
  Dim O As Long
  
  If Not m_Finished Then Solve
  Ex = Abs(Exponent)
  O = m_GlobalO
  If XYCount <= O Then O = XYCount - 1
  If O < Ex Then Coeff = 0# Else Coeff = m_C(Ex)
End Property

Public Property Get XYCount() As Long
  XYCount = CLng(m_SumX(0))
End Property

Public Sub Init()
  Dim i As Long
  
  m_Finished = False
  For i = 0 To MaxO
    m_SumX(i) = 0#
    m_SumX(i + MaxO) = 0#
    m_SumYX(i) = 0#
    m_C(i) = 0#
  Next i
End Sub

Public Function XYAdd(ByVal NewX As Double, ByVal NewY As Double)
  Dim i As Long
  Dim j As Long
  Dim TX As Double
  Dim Max2O As Double
  
  m_Finished = False
  Max2O = 2 * m_GlobalO
  TX = 1#
  m_SumX(0) = m_SumX(0) + 1
  m_SumYX(0) = m_SumYX(0) + NewY
  For i = 1 To m_GlobalO
    TX = TX * NewX
    m_SumX(i) = m_SumX(i) + TX
    m_SumYX(i) = m_SumYX(i) + NewY * TX
  Next i
  For i = m_GlobalO + 1 To Max2O
    TX = TX * NewX
    m_SumX(i) = m_SumX(i) + TX
  Next i
End Function

Public Function RegVal(X As Double) As Double
  Dim i As Long
  Dim O As Long
  
  If Not m_Finished Then Solve
  RegVal = 0#
  O = m_GlobalO
  If XYCount <= O Then O = XYCount - 1
  For i = 0 To O
    RegVal = RegVal + m_C(i) * X ^ i
  Next i
End Function


Private Sub GaussSolve(O&)
'gauss algorithm implementation,
'following R.Sedgewick's "Algorithms in C", Addison-Wesley, with minor modifications
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim iMax As Long
  Dim T As Double
  Dim O1 As Double
  
  O1 = O + 1
  'first triangulize the matrix
  For i = 0 To O
    iMax = i: T = Abs(m_M(iMax, i))
    For j = i + 1 To O 'find the line with the largest absvalue in this row
      If T < Abs(m_M(j, i)) Then iMax = j: T = Abs(m_M(iMax, i))
    Next j
    If i < iMax Then 'exchange the two lines
      For k = i To O1
        T = m_M(i, k)
        m_M(i, k) = m_M(iMax, k)
        m_M(iMax, k) = T
      Next k
    End If
    For j = i + 1 To O 'scale all following lines to have a leading zero
      T = m_M(j, i) / m_M(i, i)
      m_M(j, i) = 0#
      For k = i + 1 To O1
        m_M(j, k) = m_M(j, k) - m_M(i, k) * T
      Next k
    Next j
  Next i
  'then substitute the coefficients
  For j = O To 0 Step -1
    T = m_M(j, O1)
    For k = j + 1 To O
      T = T - m_M(j, k) * m_C(k)
    Next k
    m_C(j) = T / m_M(j, j)
  Next j
  m_Finished = True
End Sub

Private Sub BuildMatrix(O As Long)
  Dim i As Long
  Dim k As Long
  Dim O1 As Long
  
  O1 = O + 1
  For i = 0 To O
    For k = 0 To O
      m_M(i, k) = m_SumX(i + k)
    Next k
    m_M(i, O1) = m_SumYX(i)
  Next i
End Sub

Private Sub FinalizeMatrix(O As Long)
  Dim i As Long
  Dim O1 As Long
  
  O1 = O + 1
  For i = 0 To O
    m_M(i, O1) = m_SumYX(i)
  Next i
End Sub

Private Sub Solve()
  Dim O As Long
  
  O = m_GlobalO
  If XYCount <= O Then O = XYCount - 1
  If O < 0 Then Exit Sub
  BuildMatrix O
  On Error Resume Next
    GaussSolve (O)
    While (Err.Number <> 0) And (1 < O)
      Err.Clear
      m_C(0) = 0#
      O = O - 1
      FinalizeMatrix (O)
    Wend
  On Error GoTo 0
End Sub

Private Sub Class_Initialize()
  Init
  m_GlobalO = 2
End Sub