bivariateregressor.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 = "BivariateRegressor"
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 class uses the GeneralRegressor class to calculate a bivariate correlation
'between two fields in a table.  It calculate residuals from the regression and
'stores tham in a specified field (if that field does not exist, it will be added).
'If the field is not specified, it will default to "ErrorTerm".

Option Explicit

Private m_pSourceTable As ITable
Private m_pXField As String
Private m_pYField As String
Private m_pErrField As String
Private m_XExclude As Double
Private m_YExclude As Double
Private m_RSquared As Double
Private m_Reg As GeneralRegressor
Private m_Regressed As Boolean
Private m_Exclude0 As Boolean
Private m_MeanX As Double
Private m_MeanY As Double
Private m_MaxX As Double
Private m_MinX As Double
Private m_MaxY As Double
Private m_MinY As Double
Private m_LineStart As IPoint
Private m_LineEnd As IPoint

Private Sub Class_Initialize()
  m_Regressed = False
  Set m_Reg = New GeneralRegressor
  m_Reg.Degree = 1
  m_Reg.Init
  m_pErrField = "ErrorTerm"
End Sub

'Source Table
Public Property Set SourceTable(RHS As ITable)
  Set m_pSourceTable = RHS
  m_Regressed = False
End Property

Public Property Get SourceTable() As ITable
  Set SourceTable = m_pSourceTable
End Property

'XField as a text string
Public Property Let XField(RHS As String)
  m_pXField = RHS
  m_Regressed = False
End Property

Public Property Get XField() As String
  XField = m_pXField
End Property

'YField as a text string
Public Property Let YField(RHS As String)
  m_pYField = RHS
  m_Regressed = False
End Property

Public Property Get YField() As String
  YField = m_pYField
End Property

'Error field as as a text string (will hold the residual values)
Public Property Let ErrField(RHS As String)
  m_pErrField = RHS
  Dim pFields As IFields
  Set pFields = m_pSourceTable.Fields
  If (-1 = pFields.FindField(m_pErrField)) Then AddErrorField
End Property

Public Property Get ErrField() As String
  ErrField = m_pErrField
End Property

'Rows that contain this value in the X field are excluded from the
'correlation.
Public Property Let XExclude(RHS As Double)
  m_XExclude = RHS
  m_Regressed = False
End Property

Public Property Get XExclude() As Double
  XExclude = m_XExclude
End Property

'Rows that contain this value in the Y field are excluded from the
'correlation.
Public Property Let YExclude(RHS As Double)
  m_YExclude = RHS
  m_Regressed = False
End Property

Public Property Get YExclude() As Double
  YExclude = m_YExclude
End Property

'Boolean that determines whether or not to include rows
'containing zero in either the X or the Y field
Public Property Let ExcludeZero(RHS As Boolean)
  m_Exclude0 = RHS
  m_Regressed = False
End Property

Public Property Get ExcludeZero() As Boolean
  ExcludeZero = m_Exclude0
End Property

'Reports the R-squared value for the regression.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get RSquared() As Double
  If Not m_Regressed Then
    regress
  End If
  RSquared = m_RSquared
End Property

'Reports the Y intercept for the regression equation.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get YIntercept() As Double
  If Not m_Regressed Then
    regress
  End If
  YIntercept = m_Reg.Coeff(0)
End Property

'Reports the slope for the regression equation.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get slope() As Double
  If Not m_Regressed Then
    regress
  End If
  slope = m_Reg.Coeff(1)
End Property

'Reports the minimum value for the X Field.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get MinX() As Double
  If Not m_Regressed Then
    regress
  End If
  MinX = m_MinX
End Property

'Reports the maximum value for the X Field.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get MaxX() As Double
  If Not m_Regressed Then
    regress
  End If
  MaxX = m_MaxX
End Property

'Reports the minimum value for the Y Field.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get MinY() As Double
  If Not m_Regressed Then
    regress
  End If
  MinY = m_MinY
End Property

'Reports the maximum value for the Y Field.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get MaxY() As Double
  If Not m_Regressed Then
    regress
  End If
  MaxY = m_MaxY
End Property

'Reports the start point of the regression curve.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get LineStart() As IPoint
  If Not m_Regressed Then
    regress
  End If
  Set LineStart = m_LineStart
End Property

'Reports the end point of the regression curve.  If the regression
'needs to be re-run (if one of the fields has changed... etc) it takes
'care of that
Public Property Get LineEnd() As IPoint
  If Not m_Regressed Then
    regress
  End If
  Set LineEnd = m_LineEnd
End Property

'Executes the regression using the GeneralRegressor class
Public Sub regress()
  On Error GoTo ErrorHandler

  'Ensure that we have a source table, and X field, and a Y field
  If ((m_pSourceTable Is Nothing) Or (m_pXField = "") Or (m_pYField = "")) Then Exit Sub

  Dim pCursor As ICursor
  Dim pQueryFilter As IQueryFilter
  Dim pRow As IRow
  Dim pFields As IFields
  Dim XFldIndex As Long
  Dim YFldIndex As Long
  Dim X As Variant
  Dim Y As Variant
  Dim Include As Boolean
  
  'Get the access to the data in the table useing a cursor, and the
  'field indices for X and Y fields
  Set pQueryFilter = New QueryFilter
  Set pCursor = m_pSourceTable.Search(pQueryFilter, False)
  Set pFields = m_pSourceTable.Fields
  XFldIndex = pFields.FindField(m_pXField)
  YFldIndex = pFields.FindField(m_pYField)
  
  'If the Error Field does not exist in the table, add it
  If (-1 = pFields.FindField(m_pErrField)) Then AddErrorField
  
  'Loop through the records and add values to the general regressor object
  m_MeanX = 0
  m_MeanY = 0
  Set pRow = pCursor.NextRow
  Do
    X = pRow.Value(XFldIndex)
    Y = pRow.Value(YFldIndex)
    
    'Check  to see if this record should be excluded
    Include = Not (IsNull(X) Or IsNull(Y) Or (X = m_XExclude) Or (Y = m_YExclude))
    Include = Not ((m_Exclude0 And (X = 0 Or Y = 0)) Or Not Include)
    If Include Then
      m_Reg.XYAdd X, Y
      m_MeanX = m_MeanX + X
      m_MeanY = m_MeanY + Y
    End If
    
    Set pRow = pCursor.NextRow
  Loop Until (pRow Is Nothing)
  
  'If any records are included, calculate mean values and run the R-squared calculator
  If (m_Reg.XYCount = 0) Then
    MsgBox "No data found"
  Else
    m_MeanX = m_MeanX / m_Reg.XYCount
    m_MeanY = m_MeanY / m_Reg.XYCount
    CalcRSquared
    m_Regressed = True
  End If
  
  GoTo EndProc
ErrorHandler:
  MsgBox "Regress: " & Err.Number & "  " & Err.Description
EndProc:
End Sub

'Calculate the R-squared and populate the error field
Private Sub CalcRSquared()
  On Error GoTo ErrorHandler
  
  Dim pCursor As ICursor
  Dim pQueryFilter As IQueryFilter
  Dim pRow As IRow
  Dim pFields As IFields
  Dim XFldIndex As Long
  Dim YFldIndex As Long
  Dim EFldIndex As Long ' Error term field Index
  Dim X As Variant
  Dim Y As Variant
  Dim dblSlope As Double
  Dim dblInter As Double
  Dim dblVariation As Double
  Dim dblExplained As Double
  Dim estY As Double
  Dim Include As Boolean
  
  'Get the access to the data in the table useing a cursor, and the
  'field indices for X, Y, and error fields
  Set pQueryFilter = New QueryFilter
  Set pCursor = m_pSourceTable.Search(pQueryFilter, False)
  
  Set pFields = m_pSourceTable.Fields
  XFldIndex = pFields.FindField(m_pXField)
  YFldIndex = pFields.FindField(m_pYField)
  EFldIndex = pFields.FindField(m_pErrField)
  
  'Get the slopw and Y intercept from the General regressor
  dblSlope = m_Reg.Coeff(1)
  dblInter = m_Reg.Coeff(0)
  
  'Loop through the table calculatin X and Y min and max, estimated Y value,
  'variation, explained variation, and residual
  m_MaxX = -1.79769313486231E+308
  m_MinX = 1.79769313486231E+308
  m_MaxY = -1.79769313486231E+308
  m_MinY = 1.79769313486231E+308
  dblVariation = 0
  dblExplained = 0
  Do
    Set pRow = pCursor.NextRow
    If Not (pRow Is Nothing) Then
      X = pRow.Value(XFldIndex)
      Y = pRow.Value(YFldIndex)
      
      'Check  to see if this record should be excluded
      Include = Not (IsNull(X) Or IsNull(Y) Or (X = m_XExclude) Or (Y = m_YExclude))
      Include = Not ((m_Exclude0 And (X = 0 Or Y = 0)) Or Not Include)
      If Include Then
        m_MaxX = Max(m_MaxX, X)
        m_MinX = Min(m_MinX, X)
        m_MaxY = Max(m_MaxY, Y)
        m_MinY = Min(m_MinY, Y)
          
        'Calculate expected (estimated) Y value
        estY = dblInter + (X * dblSlope)
        
        'Calculate variation
        dblVariation = dblVariation + ((Y - m_MeanY) ^ 2)
        
        'Calculate explained variation
        dblExplained = dblExplained + ((estY - m_MeanY) ^ 2)
        
        'Calculate residual and write it to the table
        pRow.Value(EFldIndex) = CDbl(estY - Y)
      Else
        'If the record is not included, set the value for the error field to Null
        pRow.Value(EFldIndex) = Null
      End If
      pRow.Store
    End If
  Loop Until (pRow Is Nothing)
  If (dblVariation = 0) Then
    MsgBox "Variation is equal to 0. Unable to calculate R squared"
  Else
    m_RSquared = (dblExplained / dblVariation)
  End If
  
  'Get the coordiantes for the regression line
  Set m_LineEnd = New esriGeometry.Point
  Set m_LineStart = New esriGeometry.Point
  m_LineEnd.X = m_MaxX
  m_LineEnd.Y = dblInter + (m_MaxX * dblSlope)
  m_LineStart.X = m_MinX
  m_LineStart.Y = dblInter + (m_MinX * dblSlope)

  GoTo EndProc
ErrorHandler:
  MsgBox "CalcRSquared: " & Err.Number & "  " & Err.Description
  
EndProc:
End Sub

'Add the error field to the source table
Private Sub AddErrorField()
  On Error GoTo ErrorHandler

  Dim pField As IField
  Dim pFieldEdit As IFieldEdit

  Set pField = New Field
  Set pFieldEdit = pField

  With pFieldEdit
      .AliasName = m_pErrField
      .Editable = True
      .IsNullable = True
      .Length = 16
      .Name = m_pErrField
      .Precision = 0
      .Scale = 0
      .Type = esriFieldTypeDouble
  End With

  Set pField = pFieldEdit
  m_pSourceTable.AddField pField

  GoTo EndProc
ErrorHandler:
  MsgBox "AddErrorField: " & Err.Number & "  " & Err.Description
EndProc:
End Sub

Private Function Max(num1 As Double, num2 As Variant) As Double
  If (num1 > num2) Then
    Max = num1
  Else
    Max = num2
  End If
End Function

Private Function Min(num1 As Double, num2 As Variant) As Double
  If (num1 < num2) Then
    Min = num1
  Else
    Min = num2
  End If
End Function