The following program calculates the the best model and statistical coefficients for the following model:
H(Y) = A + B F(X1) + C G(X2)
Where X1, and X2 are independent variables and Y is the dependent variable. In addition, H(), F(), and G() are transformation functions for the regression variables. The program also calculates the coefficient of determination R-Square.
The program performs different transformations on all the variables. These transformations include:
The program attempts to fit a a large combination of different curves. For data that have only positive values, the program succeeds in calculating all different models. The presence of negative values and zeros will reduce the number of models tested. The application skips certain transformations for an entire data set if ANY value is zero and/or negative. The bypass prevents run-time errors. Skipping a transformation for an entire data set makes the models easier to compare since they all are based on the same number of observations.
Click here to download a ZIP file containing the project files for this program.
The program is a Windows application that has the following interface:
The above interface has the following controls:
The application reads data from text files. Each line in the source text file may be one of the following:
Here is an example of a data file:
Sample Data file
Created 1/31/2006
General format for a data line is (the Weight value is optional):
X1,X2,Y[,Weight]
Next we have X1 = 100, X2 = 23 and Y = 212
100,23,212
Notice leading spaces on next line
10,50,43
The next line has a commented observation
! 33,45,67
25,77,98
Next data line has a weight value of 2 (X1 = 30, X2 = 45, Y = 86, and weight = 2)
30,45,86,2
The application allows for flexible commenting throughout the text file and is able to extract the data. You can add leading characters like !, #, or % as the first character of a comment line. This option may make it easier for the human eye to spot comment lines. It may also make it easier for a separate utility program to strip the comment lines.
One reason clicking the Read Data button displays the data is to allow you to double check the integrity of the data. If a data line has only one value, then the application generates flags an error. If a data line has more than 4 values, the program ignores the extra values and does not raise an error.
The application shifts and scales data using the following formulas:
X1' = ScaleX1 * (X1 - ShiftX1)
X2' = ScaleX2 * (X2 - ShiftX2)
Y' = ScaleY * (Y - ShiftY)
Keep the above equations in mind when you assign values for the shift and/or scale factors.
Some of the mathematical transformations used take arguments that are only positive or only non-negative. In case you source data contains zeros and/or negative values, the application will avoid applying certain mathematical transformation to avoid causing run-time errors. Keep in mind that the program applies such avoidance to the entire data set and not just to those specific values that can cause error. You will notice the difference in the number of models display depending on your source data range. When using all-positive observations, the applications applies the entire set of transformations. When you have zeros or negative values, the application applies fewer transformations.
Here is a sample output:
The above output shows the first few best regression models. Here is the simple help message box:
The project file contains the following modules and classes of interest:
Here is the listing for class Form1:
Imports System.IO
Public Class Form1
Private sDataFilename As String
Private bEditMode As Boolean
Private bTextHasChanged As Boolean
Private Sub cmdCalc_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdCalc.Click
Dim objLR As CStatSum
Dim objRes As CResults
Dim I, N, nDataCount As Integer
Dim fShiftArr(3), fScaleArr(3) As Double
Dim sBuffer As String
If sDataFilename = "" Then
MessageBox.Show("Please select a data file first", "Error", MessageBoxButtons.OK, MessageBoxIcon.Hand)
Exit Sub
End If
If bTextHasChanged Then
If MessageBox.Show("Save changed data?", "Confirmation", MessageBoxButtons.YesNo, MessageBoxIcon.Question) = Windows.Forms.DialogResult.Yes Then
File.WriteAllText(sDataFilename, txtRes.Text)
End If
bTextHasChanged = False
End If
bEditMode = False
If txtMaxResults.Text.Length > 0 Then
N = Integer.Parse(txtMaxResults.Text)
If N < 1 Then N = 32000
Else
N = 32000
End If
objLR = New CStatSum
objRes = New CResults
' check the Shift Y text box
If txtShiftY.Text.Length > 0 Then
fShiftArr(0) = Double.Parse(txtShiftY.Text)
Else
fShiftArr(0) = 0
End If
' check the Shift X1 text box
If txtShiftX1.Text.Length > 0 Then
fShiftArr(1) = Double.Parse(txtShiftX1.Text)
Else
fShiftArr(1) = 0
End If
' check the Shift X2 text box
If txtShiftX2.Text.Length > 0 Then
fShiftArr(2) = Double.Parse(txtShiftX2.Text)
Else
fShiftArr(2) = 0
End If
' check the Scale Y text box
If txtScaleY.Text.Length > 0 Then
fScaleArr(0) = Double.Parse(txtScaleY.Text)
If fScaleArr(0) = 0 Then fScaleArr(0) = 1
Else
fScaleArr(0) = 1
End If
' check the Scale X1 text box
If txtScaleX1.Text.Length > 0 Then
fScaleArr(1) = Double.Parse(txtScaleX1.Text)
If fScaleArr(1) = 0 Then fScaleArr(1) = 1
Else
fScaleArr(1) = 1
End If
' check the Scale X2 text box
If txtScaleX2.Text.Length > 0 Then
fScaleArr(2) = Double.Parse(txtScaleX2.Text)
If fScaleArr(2) = 0 Then fScaleArr(2) = 1
Else
fScaleArr(2) = 1
End If
If objLR.GetData(sDataFilename, nDataCount, fShiftArr, fScaleArr) Then
Cursor = Cursors.WaitCursor
objLR.FindBestFit(objRes)
objRes.SortResults()
sBuffer = "Source Data File: " & sDataFilename & vbCrLf & vbCrLf
sBuffer = sBuffer & "Date/Time: " & Now() & vbCrLf & vbCrLf
sBuffer = sBuffer & "Nnmber of observations = " & nDataCount & vbCrLf & vbCrLf
If fScaleArr(0) <> 1 Then sBuffer = sBuffer & "Scale Y = " & fScaleArr(0) & vbCrLf
If fShiftArr(0) <> 0 Then sBuffer = sBuffer & "Shift Y = " & fShiftArr(0) & vbCrLf
If fScaleArr(1) <> 1 Then sBuffer = sBuffer & "Scale X1 = " & fScaleArr(1) & vbCrLf
If fShiftArr(1) <> 0 Then sBuffer = sBuffer & "Shift X1 = " & fShiftArr(1) & vbCrLf
If fScaleArr(2) <> 1 Then sBuffer = sBuffer & "Scale X2 = " & fScaleArr(2) & vbCrLf
If fShiftArr(2) <> 0 Then sBuffer = sBuffer & "Shift X2 = " & fShiftArr(2) & vbCrLf
N = IIf(objRes.Count > N, N, objRes.Count)
For I = 0 To N - 1
sBuffer = sBuffer & "R-Sqr = " & objRes.GetR2(I).ToString & vbCrLf
sBuffer = sBuffer & "Model: " & objRes.GetModel(I) & vbCrLf
sBuffer = sBuffer & "A = " & objRes.GetIntercept(I).ToString & _
", B1 = " & objRes.GetSlope1(I).ToString & _
", B2 = " & objRes.GetSlope2(I).ToString & vbCrLf
Next
txtRes.Text = sBuffer
sBuffer = ""
Cursor = Cursors.Default
cmdSaveRes.Enabled = True
Else
MessageBox.Show("Error in processing data", "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
sDataFilename = ""
cmdCalc.Enabled = False
cmdSaveRes.Enabled = False
bEditMode = False
End Sub
Private Sub cmdReadData_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdReadData.Click
dlgReadData.Filter = "All files (*.*)|*.*|Text files|*.txt|Data files (*.dat)|*.dat"
If dlgReadData.ShowDialog = Windows.Forms.DialogResult.OK Then
sDataFilename = dlgReadData.FileName
txtRes.Text = File.ReadAllText(sDataFilename)
cmdCalc.Enabled = True
cmdSaveRes.Enabled = True
bTextHasChanged = False
bEditMode = True
End If
End Sub
Private Sub cmdSaveRes_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdSaveRes.Click
dlgSaveRes.Filter = "All files (*.*)|*.*|Text files|*.txt|Data files (*.dat)|*.dat"
If dlgSaveRes.ShowDialog = Windows.Forms.DialogResult.OK Then
File.WriteAllText(dlgSaveRes.FileName, txtRes.Text)
bTextHasChanged = False
End If
End Sub
Private Sub cmdClose_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdClose.Click
If MessageBox.Show("Close application?", "Confirmation", MessageBoxButtons.YesNo, MessageBoxIcon.Question) = Windows.Forms.DialogResult.Yes Then
Close()
End If
End Sub
Private Sub txtRes_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles txtRes.TextChanged
If bEditMode Then bTextHasChanged = True
End Sub
Private Sub cmdHelp_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdHelp.Click
Dim sText As String
Dim I As Integer
sText = "Each line can be 1) empty, 2) a comment line or 3) a data line" & vbCrLf & _
"A data line has a set of y, x1, and x2 values separated by commas" & vbCrLf & _
"A data line can have a weight value that is appended after x2 and is separated by a comma" & vbCrLf & _
"Weights are optional and need to appear when their values are not 1" & vbCrLf & _
"A comment line must NOT start with any of the chatacters +-.0123456789" & vbCrLf & _
"Show an example?"
If MessageBox.Show(sText, "Help", MessageBoxButtons.YesNo, MessageBoxIcon.Information) = Windows.Forms.DialogResult.Yes Then
bEditMode = False
sText = "Sample data (example of free form comment line)" & vbCrLf & _
"45,32,44" & vbCrLf & _
"67,34,55" & vbCrLf & _
"Next line is an observation that is temporaryly commente dout" & vbCrLf & _
"! 56,23,18" & vbCrLf
For I = 1 To 10
sText = sText & Int(200 * Rnd(1)) & "," & Int(200 * Rnd(1)) & "," & Int(100 * Rnd(1)) & vbCrLf
Next
txtRes.Text = sText
End If
End Sub
End Class
Here is the listing for module TypeModule:
Module TYpeModule
Public Enum FitType
eLinear
eSquare
eCube
eCubeRoot
eRecip
eRecipCubeRoot
eRecipSquare
eRecipCube
eSqrt
eRecipSqrt
eLn
End Enum
Public Structure ResType
Public m_sModel As String
Public m_fR2 As Double
Public m_fSlope1 As Double
Public m_fSlope2 As Double
Public m_fIntercept As Double
Public m_sErr As String
End Structure
End Module
Here is the listing for class CErrors:
Public Class CErrors
Private m_sErrors() As String
Private m_nNumErrs As Integer
Public Sub New()
Clear()
End Sub
Public Sub Add(ByVal sErr As String)
ReDim Preserve m_sErrors(m_nNumErrs + 1)
m_sErrors(m_nNumErrs) = sErr
m_nNumErrs = m_nNumErrs + 1
End Sub
Public Function GetCount() As Integer
Return m_nNumErrs
End Function
Public Function GetErrText(ByVal nIndex As Integer) As String
Dim sErrText As String = "Out of Bound Index"
Try
sErrText = m_sErrors(nIndex)
Catch
End Try
Return sErrText
End Function
Public Sub Clear()
m_nNumErrs = 0
ReDim m_sErrors(1)
End Sub
End Class
Here is the listing for class CResults::
Public Class CResults
Private m_nResCount As Integer
Private m_uResRec() As TYpeModule.ResType
Public Sub New()
m_nResCount = 0
End Sub
Public Sub Add(ByVal sModel As String, ByVal fR2 As Double, ByVal fSlope1 As Double, ByVal fSlope2 As Double, ByVal fIntercept As Double, ByVal sErr As String)
ReDim Preserve m_uResRec(m_nResCount + 1)
m_uResRec(m_nResCount).m_sModel = sModel
m_uResRec(m_nResCount).m_fR2 = fR2
m_uResRec(m_nResCount).m_fSlope1 = fSlope1
m_uResRec(m_nResCount).m_fSlope2 = fSlope2
m_uResRec(m_nResCount).m_fIntercept = fIntercept
m_uResRec(m_nResCount).m_sErr = sErr
m_nResCount = m_nResCount + 1
End Sub
Public Sub Clear()
m_nResCount = 0
End Sub
Public Function Count() As Integer
Return m_nResCount
End Function
Public Function GetModel(ByVal nIndex As Integer) As String
Return IIf(nIndex > -1 And nIndex < m_nResCount, m_uResRec(nIndex).m_sModel, "")
End Function
Public Function GetR2(ByVal nIndex As Integer) As Double
Return IIf(nIndex > -1 And nIndex < m_nResCount, m_uResRec(nIndex).m_fR2, -1)
End Function
Public Function GetSlope1(ByVal nIndex As Integer) As Double
Return IIf(nIndex > -1 And nIndex < m_nResCount, m_uResRec(nIndex).m_fSlope1, -1.0E+30)
End Function
Public Function GetSlope2(ByVal nIndex As Integer) As Double
Return IIf(nIndex > -1 And nIndex < m_nResCount, m_uResRec(nIndex).m_fSlope2, -1.0E+30)
End Function
Public Function GetIntercept(ByVal nIndex As Integer) As Double
Return IIf(nIndex > -1 And nIndex < m_nResCount, m_uResRec(nIndex).m_fIntercept, -1.0E+30)
End Function
Public Function GetErr(ByVal nIndex As Integer) As String
Return IIf(nIndex > -1 And nIndex < m_nResCount, m_uResRec(nIndex).m_sErr, "")
End Function
Public Sub SortResults()
Dim bInorder As Boolean
Dim I, J, N, nOffset, nResetCounter As Integer
Dim uBuffer As TYpeModule.ResType
N = m_nResCount
nOffset = N
nResetCounter = 0
Do
nOffset = (5 * nOffset) / 11
If nOffset = 0 Then nOffset = 1
bInorder = True
For I = 0 To N - nOffset - 1
J = I + nOffset
If m_uResRec(I).m_fR2 < m_uResRec(J).m_fR2 Then
uBuffer = m_uResRec(I)
m_uResRec(I) = m_uResRec(J)
m_uResRec(J) = uBuffer
bInorder = False
End If
Next
If bInorder Then nResetCounter += 1
If (Not bInorder) And (nOffset = 1) Then
nOffset = N
For I = 1 To nResetCounter
nOffset = (5 * nOffset) / 11
Next
If nOffset = 0 Then nOffset = 1
End If
Loop Until nOffset = 1 And bInorder
End Sub
End Class
Here is the listing for class CStatSum:
Imports System.IO
Public Class CStatSum
Const EPSILON = 0.0000000001
Private Const DIGIT_MARKERS = "-+0123456789."
Private m_bZeroX1 As Boolean
Private m_bZeroX2 As Boolean
Private m_bZeroY As Boolean
Private m_bNegX1 As Boolean
Private m_bNegX2 As Boolean
Private m_bNegY As Boolean
Private m_fSum As Double
Private m_fSumX11 As Double
Private m_fSumX21 As Double
Private m_fSumX22 As Double
Private m_fSumX12 As Double
Private m_fSumY As Double
Private m_fSumY2 As Double
Private m_fSumX1Y As Double
Private m_fSumX2Y As Double
Private m_fSumX1X2 As Double
Private m_fMeanX1 As Double
Private m_fMeanX2 As Double
Private m_fMeanY As Double
Private m_fSdevX1 As Double
Private m_fSdevX2 As Double
Private m_fSdevY As Double
Private m_fSlope1 As Double
Private m_fSlope2 As Double
Private m_fIntercept As Double
Private m_fR2 As Double
Private m_sTX1 As String
Private m_sTX2 As String
Private m_sTY As String
Private m_nDataCount As Integer
Private m_fX1() As Double
Private m_fX2() As Double
Private m_fY() As Double
Private m_fWt() As Double
Public Sub InitSums()
m_fSum = 0
m_fSumX11 = 0
m_fSumX12 = 0
m_fSumX21 = 0
m_fSumX22 = 0
m_fSumY = 0
m_fSumY2 = 0
m_fSumX1Y = 0
m_fSumX2Y = 0
m_fSumX1X2 = 0
m_sTX1 = ""
m_sTX2 = ""
m_sTY = ""
End Sub
Public Sub New()
InitSums()
End Sub
Public Function GetData(ByVal sDataFilename As String, ByRef nDataCount As Integer, _
ByRef fShiftArr() As Double, ByRef fScaleArr() As Double) As Boolean
Dim sLine, sLines() As String
Dim sData() As String
Dim I, J, K, N As Integer
Dim bRes As Boolean = True
Try
sLines = File.ReadAllLines(sDataFilename)
nDataCount = sLines.GetUpperBound(0)
' Dimension arrays for maximum capacity
ReDim m_fX1(nDataCount)
ReDim m_fX2(nDataCount)
ReDim m_fY(nDataCount)
ReDim m_fWt(nDataCount)
J = 0
m_nDataCount = 0
Do Until J = sLines.Length
sLine = sLines(J).Trim()
' is line not empty?
If sLine.Length > 0 Then
' is it NOT a comment?
If DIGIT_MARKERS.IndexOf(sLine.Substring(0, 1)) >= 0 Then
sData = sLine.Split(",")
N = sData.GetUpperBound(0)
m_fY(m_nDataCount) = Double.Parse(sData(0))
m_fX1(m_nDataCount) = Double.Parse(sData(1))
m_fX2(m_nDataCount) = Double.Parse(sData(1))
If N < 3 Then
m_fWt(m_nDataCount) = 1
Else
m_fWt(m_nDataCount) = Double.Parse(sData(2))
End If
m_nDataCount += 1
End If
End If
J += 1
Loop
' adjust arrays to actual number of data
ReDim Preserve m_fX1(m_nDataCount)
ReDim Preserve m_fX2(m_nDataCount)
ReDim Preserve m_fY(m_nDataCount)
ReDim Preserve m_fWt(m_nDataCount)
nDataCount = m_nDataCount
For I = 0 To m_nDataCount - 1
m_fX1(I) = fScaleArr(1) * (m_fX1(I) - fShiftArr(1))
m_fX2(I) = fScaleArr(2) * (m_fX2(I) - fShiftArr(2))
m_fY(I) = fScaleArr(0) * (m_fY(I) - fShiftArr(0))
Next I
Catch ex As Exception
bRes = False
End Try
Return bRes
End Function
Private Sub Add(ByVal X1 As Double, ByVal X2 As Double, ByVal Y As Double, Optional ByVal Wt As Double = 1)
m_fSum = m_fSum + Wt
m_fSumX11 = m_fSumX11 + X1 * Wt
m_fSumX21 = m_fSumX21 + X2 * Wt
m_fSumX12 = m_fSumX12 + X1 * X1 * Wt
m_fSumX22 = m_fSumX22 + X2 * X2 * Wt
m_fSumY = m_fSumY + Y * Wt
m_fSumY2 = m_fSumY2 + Y * Y * Wt
m_fSumX1Y = m_fSumX1Y + X1 * Y * Wt
m_fSumX2Y = m_fSumX2Y + X2 * Y * Wt
m_fSumX1X2 = m_fSumX1X2 + X1 * X2 * Wt
End Sub
Public Sub FindBestFit(ByRef objRes As CResults)
Dim I As Integer
Dim ITX1 As FitType
Dim ITX2 As FitType
Dim ITY As FitType
Dim bOK As Boolean
Dim fXt1 As Double
Dim fXt2 As Double
Dim fYt As Double
Dim objErrs As CErrors
Dim sModel As String
Dim sErr As String
objErrs = New CErrors
Try
m_bZeroX1 = False
m_bZeroX1 = False
m_bZeroY = False
m_bNegX1 = False
m_bNegX2 = False
m_bNegY = False
objRes.Clear()
For I = 0 To m_nDataCount - 1
If m_fX1(I) < 0 Then m_bNegX1 = True
If m_fX2(I) < 0 Then m_bNegX2 = True
If m_fY(I) < 0 Then m_bNegY = True
If Math.Abs(m_fX1(I)) < EPSILON Then m_bZeroX1 = True
If Math.Abs(m_fX2(I)) < EPSILON Then m_bZeroX2 = True
If Math.Abs(m_fY(I)) < EPSILON Then m_bZeroY = True
Next I
For ITY = TYpeModule.FitType.eLinear To TYpeModule.FitType.eLn
' validate transformations
If m_bZeroY And m_bNegY Then
bOK = CanHandleZeroAndNegative(ITY)
ElseIf m_bZeroY Then
bOK = CanHandleZero(ITY)
ElseIf m_bNegY Then
bOK = CanHandleNegative(ITY)
Else
bOK = True
End If
' Can proceed?
If bOK Then
For ITX1 = TYpeModule.FitType.eLinear To TYpeModule.FitType.eLn
' validate transformations
If m_bZeroX1 And m_bNegX1 Then
bOK = CanHandleZeroAndNegative(ITX1)
ElseIf m_bZeroX1 Then
bOK = CanHandleZero(ITX1)
ElseIf m_bNegX1 Then
bOK = CanHandleNegative(ITX1)
Else
bOK = True
End If
' Can proceed?
If bOK Then
For ITX2 = TYpeModule.FitType.eLinear To TYpeModule.FitType.eLn
' validate transformations
If m_bZeroX2 And m_bNegX2 Then
bOK = CanHandleZeroAndNegative(ITX2)
ElseIf m_bZeroX2 Then
bOK = CanHandleZero(ITX2)
ElseIf m_bNegX2 Then
bOK = CanHandleNegative(ITX2)
Else
bOK = True
End If
' lastly check if two transformations are the same
If ITX1 = ITX2 Then bOK = False
If bOK Then
' initialize summations
InitSums()
For I = 0 To m_nDataCount - 1
Select Case ITX1
Case TYpeModule.FitType.eLinear
fXt1 = m_fX1(I)
Case TYpeModule.FitType.eSquare
fXt1 = m_fX1(I) ^ 2
Case TYpeModule.FitType.eCube
fXt1 = m_fX1(I) ^ 3
Case TYpeModule.FitType.eCubeRoot
fXt1 = m_fX1(I) ^ (1 / 3)
Case TYpeModule.FitType.eRecip
fXt1 = 1 / m_fX1(I)
Case TYpeModule.FitType.eRecipCubeRoot
fXt1 = 1 / m_fX1(I) ^ (1 / 3)
Case TYpeModule.FitType.eRecipSquare
fXt1 = 1 / m_fX1(I) ^ 2
Case TYpeModule.FitType.eRecipCube
fXt1 = 1 / m_fX1(I) ^ 3
Case TYpeModule.FitType.eSqrt
fXt1 = Math.Sqrt(m_fX1(I))
Case TYpeModule.FitType.eRecipSqrt
fXt1 = 1 / Math.Sqrt(m_fX1(I))
Case TYpeModule.FitType.eLn
fXt1 = Math.Log(m_fX1(I))
End Select
Select Case ITX2
Case TYpeModule.FitType.eLinear
fXt2 = m_fX2(I)
Case TYpeModule.FitType.eSquare
fXt2 = m_fX2(I) ^ 2
Case TYpeModule.FitType.eCube
fXt2 = m_fX2(I) ^ 3
Case TYpeModule.FitType.eCubeRoot
fXt2 = m_fX2(I) ^ (1 / 3)
Case TYpeModule.FitType.eRecip
fXt2 = 1 / m_fX2(I)
Case TYpeModule.FitType.eRecipCubeRoot
fXt2 = 1 / m_fX2(I) ^ (1 / 3)
Case TYpeModule.FitType.eRecipSquare
fXt2 = 1 / m_fX2(I) ^ 2
Case TYpeModule.FitType.eRecipCube
fXt2 = 1 / m_fX2(I) ^ 3
Case TYpeModule.FitType.eSqrt
fXt2 = Math.Sqrt(m_fX2(I))
Case TYpeModule.FitType.eRecipSqrt
fXt2 = 1 / Math.Sqrt(m_fX2(I))
Case TYpeModule.FitType.eLn
fXt2 = Math.Log(m_fX2(I))
End Select
Select Case ITY
Case TYpeModule.FitType.eLinear
fYt = m_fY(I)
Case TYpeModule.FitType.eSquare
fYt = m_fY(I) ^ 2
Case TYpeModule.FitType.eCube
fYt = m_fY(I) ^ 3
Case TYpeModule.FitType.eCubeRoot
fYt = m_fY(I) ^ (1 / 3)
Case TYpeModule.FitType.eRecip
fYt = 1 / m_fY(I)
Case TYpeModule.FitType.eRecipCubeRoot
fYt = 1 / m_fY(I) ^ (1 / 3)
Case TYpeModule.FitType.eRecipSquare
fYt = 1 / m_fY(I) ^ 2
Case TYpeModule.FitType.eRecipCube
fYt = 1 / m_fY(I) ^ 3
Case TYpeModule.FitType.eSqrt
fYt = Math.Sqrt(m_fY(I))
Case TYpeModule.FitType.eRecipSqrt
fYt = 1 / Math.Sqrt(m_fY(I))
Case TYpeModule.FitType.eLn
fYt = Math.Log(m_fY(I))
End Select
' add transformed data to statistical summations
Add(fXt1, fXt2, fYt, m_fWt(I))
Next I
' store transformation data
m_sTX1 = SayTransform(ITX1, "X1")
m_sTX2 = SayTransform(ITX2, "X2")
m_sTY = SayTransform(ITY, "Y")
sModel = m_sTY & " = A + B1 * " & m_sTX1 & " + B2 * " & m_sTX2
' calculate regression statistics and store in
' object accessed by m_objRes
CalcLR(objRes, objErrs)
If objErrs.GetCount > 0 Then
sErr = objErrs.GetErrText(0)
Else
sErr = ""
End If
objErrs.Clear() ' reset error object
objRes.Add(sModel, m_fR2, m_fSlope1, m_fSlope2, m_fIntercept, sErr)
End If
Next ITX2
End If
Next ITX1
End If
Next ITY
Catch ex As Exception
objErrs.Add(ex.Message)
End Try
End Sub
Private Function SayTransform(ByVal eVal As FitType, Optional ByVal sVar As String = "X") As String
Select Case eVal
Case TYpeModule.FitType.eLinear
Return sVar
Case TYpeModule.FitType.eSquare
Return sVar & "^2"
Case TYpeModule.FitType.eCube
Return sVar & "^3"
Case TYpeModule.FitType.eCubeRoot
Return sVar & "^1/3"
Case TYpeModule.FitType.eRecip
Return "1/" & sVar
Case TYpeModule.FitType.eRecipCubeRoot
Return "1/" & sVar & "^1/3"
Case TYpeModule.FitType.eRecipSquare
Return "1/" & sVar & "^2"
Case TYpeModule.FitType.eRecipCube
Return "1/" & sVar & "^3"
Case TYpeModule.FitType.eSqrt
Return sVar & "^1/2"
Case TYpeModule.FitType.eRecipSqrt
Return "1/" & sVar & "^1/2"
Case TYpeModule.FitType.eLn
Return "Ln(" & sVar & ")"
End Select
End Function
Private Function CanHandleZero(ByVal eVal As FitType) As Boolean
Select Case eVal
Case TYpeModule.FitType.eLinear, TYpeModule.FitType.eSquare, _
TYpeModule.FitType.eCube, TYpeModule.FitType.eCubeRoot, TYpeModule.FitType.eSqrt
Return True
Case Else
Return False
End Select
End Function
Private Function CanHandleZeroAndNegative(ByVal eVal As FitType) As Boolean
Select Case eVal
Case TYpeModule.FitType.eLinear, TYpeModule.FitType.eSquare, TYpeModule.FitType.eCube
Return True
Case Else
Return False
End Select
End Function
Private Function CanHandleNegative(ByVal eVal As FitType) As Boolean
Select Case eVal
Case TYpeModule.FitType.eLinear, TYpeModule.FitType.eSquare, TYpeModule.FitType.eCube, _
TYpeModule.FitType.eRecip, TYpeModule.FitType.eRecipSquare, TYpeModule.FitType.eRecipCube
Return True
Case Else
Return False
End Select
End Function
Private Sub CalcLR(ByRef objRes As CResults, ByRef objErrs As CErrors)
Dim A As Double
Dim B As Double
If m_fSum < 2 Then Exit Sub
' caluclate regression
Try
m_fMeanX1 = m_fSumX11 / m_fSum
m_fMeanX2 = m_fSumX21 / m_fSum
m_fMeanY = m_fSumY / m_fSum
m_fSdevX1 = Math.Sqrt((m_fSumX12 - m_fSumX11 ^ 2 / m_fSum) / (m_fSum - 1))
m_fSdevX2 = Math.Sqrt((m_fSumX22 - m_fSumX21 ^ 2 / m_fSum) / (m_fSum - 1))
m_fSdevY = Math.Sqrt((m_fSumY2 - m_fSumY ^ 2 / m_fSum) / (m_fSum - 1))
A = (m_fSum * m_fSumX12 - m_fSumX11 ^ 2) * _
(m_fSum * m_fSumX2Y - m_fSumX21 * m_fSumY)
B = (m_fSum * m_fSumX1X2 - m_fSumX11 * m_fSumX21) * _
(m_fSum * m_fSumX1Y - m_fSumX11 * m_fSumY)
m_fSlope2 = (A - B) / _
((m_fSum * m_fSumX12 - m_fSumX11 ^ 2) * _
(m_fSum * m_fSumX22 - m_fSumX21 ^ 2) - _
(m_fSum * m_fSumX1X2 - m_fSumX11 * m_fSumX21) ^ 2)
m_fSlope1 = ((m_fSum * m_fSumX1Y - m_fSumX11 * m_fSumY) - _
m_fSlope2 * (m_fSum * m_fSumX1X2 - m_fSumX11 * m_fSumX21)) / _
(m_fSum * m_fSumX12 - m_fSumX11 ^ 2)
m_fIntercept = m_fMeanY - m_fSlope1 * m_fMeanX1 - m_fSlope2 * m_fMeanX2
m_fR2 = (m_fIntercept * m_fSumY + m_fSlope1 * m_fSumX1Y + m_fSlope2 * m_fSumX2Y - m_fSumY ^ 2 / m_fSum) / _
(m_fSumY2 - m_fSumY ^ 2 / m_fSum)
Catch ex As Exception
objErrs.Add("Error in model " & m_sTY = "A0 + A1 " & _
m_sTX1 & " + A2 " & m_sTX2 & vbCrLf & ex.Message)
End Try
End Sub
End Class
Copyright (c) Namir Shammas. All rights reserved.