The following program calculates the the best model and statistical coefficients for the following model:
H(Y) = A + B F(X) + C G(X)
Where X is the independent variable 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): X,Y[,Weight] Next we have X = 100 and Y = 212 100,212 Notice leading spaces on next line 10,50 The next line has a commented observation ! 33,45 25,77 Next data line has a weight value of 2 (X = 30, Y = 86, and weight = 2) 30,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 3 values, the program ignores the extra values and does not raise an error.
The application shifts and scales data using the following formulas:
X' = ScaleX * (X - ShiftX)
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, nDataCOunt As Integer Dim fShiftX, fShiftY, fScaleX, fScaleY 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 objLR = New CStatSum objRes = New CResults 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 ' check the Shift X text box If txtShiftX.Text.Length > 0 Then fShiftX = Double.Parse(txtShiftX.Text) Else fShiftX = 0 End If ' check the Shift Y text box If txtShiftY.Text.Length > 0 Then fShiftY = Double.Parse(txtShiftY.Text) Else fShiftY = 0 End If ' check the Scale X text box If txtScaleX.Text.Length > 0 Then fScaleX = Double.Parse(txtScaleX.Text) If fScaleX = 0 Then fScaleX = 1 Else fScaleX = 1 End If ' check the Scale Y text box If txtScaleY.Text.Length > 0 Then fScaleY = Double.Parse(txtScaleY.Text) If fScaleY = 0 Then fScaleY = 1 Else fScaleY = 1 End If If objLR.GetData(sDataFilename, nDataCOunt, fShiftX, fShiftY, fScaleX, fScaleY) 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 & "Number of observations = " & nDataCOunt & vbCrLf & vbCrLf If fScaleX <> 1 Then sBuffer = sBuffer & "Scale X = " & fScaleX & vbCrLf If fShiftX <> 0 Then sBuffer = sBuffer & "Shift X = " & fShiftX & vbCrLf If fScaleY <> 1 Then sBuffer = sBuffer & "Scale Y = " & fScaleY & vbCrLf If fShiftY <> 0 Then sBuffer = sBuffer & "Shift Y = " & fShiftY & vbCrLf & vbCrLf For I = 0 To objRes.Count - 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 pair of y and x values separated by a comma" & vbCrLf & _ "A data line can have a weight value that is appended after x 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" & vbCrLf & _ "67,34" & vbCrLf & _ "Next line is an observation that is temporaryly commente dout" & vbCrLf & _ "! 56,23" & vbCrLf For I = 1 To 10 sText = sText & Int(200 * Rnd(1)) & "," & Int(200 * Rnd(1)) & vbCrLf Next txtRes.Text = sText End If End Sub End ClassHere 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 Private Const EPSILON = 1.0E-50 Private Const DIGIT_MARKERS = "-+0123456789." Private m_bZeroX As Boolean Private m_bZeroY As Boolean Private m_bNegX 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_sWt As String Private m_nDataCount As Integer Private m_fX() 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 = "" m_sWt = "" End Sub Public Sub New() InitSums() End Sub Public Function GetData(ByVal sDataFilename As String, ByRef nDataCOunt As Integer, _ Optional ByVal ShiftX As Double = 0, Optional ByVal ShiftY As Double = 0, _ Optional ByVal ScaleX As Double = 1, Optional ByVal ScaleY As Double = 1) 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_fX(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_fX(m_nDataCount) = Double.Parse(sData(0)) m_fY(m_nDataCount) = Double.Parse(sData(1)) If N < 2 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_fX(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_fX(I) = ScaleX * (m_fX(I) - ShiftX) m_fY(I) = ScaleY * (m_fY(I) - ShiftY) 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 fMinWt As Double Dim fMaxWt As Double Dim fMeanWt As Double Dim fSdevWt As Double Dim objErrs As CErrors Dim sModel As String Dim sErr As String objErrs = New CErrors Try m_bZeroX = False m_bZeroY = False m_bNegX = False m_bNegY = False objRes.Clear() For I = 0 To m_nDataCount - 1 If m_fX(I) < 0 Then m_bNegX = True If m_fY(I) < 0 Then m_bNegY = True If Math.Abs(m_fX(I)) < EPSILON Then m_bZeroX = 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_bZeroX And m_bNegX Then bOK = CanHandleZeroAndNegative(ITX1) ElseIf m_bZeroX Then bOK = CanHandleZero(ITX1) ElseIf m_bNegX Then bOK = CanHandleNegative(ITX1) Else bOK = True End If ' Can proceed? If bOK Then For ITX2 = ITX1 To TypeModule.FitType.eLn ' validate transformations If m_bZeroX And m_bNegX Then bOK = CanHandleZeroAndNegative(ITX2) ElseIf m_bZeroX Then bOK = CanHandleZero(ITX2) ElseIf m_bNegX 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_fX(I) Case TypeModule.FitType.eSquare fXt1 = m_fX(I) ^ 2 Case TypeModule.FitType.eCube fXt1 = m_fX(I) ^ 3 Case TypeModule.FitType.eCubeRoot fXt1 = m_fX(I) ^ (1 / 3) Case TypeModule.FitType.eRecip fXt1 = 1 / m_fX(I) Case TypeModule.FitType.eRecipCubeRoot fXt1 = 1 / m_fX(I) ^ (1 / 3) Case TypeModule.FitType.eRecipSquare fXt1 = 1 / m_fX(I) ^ 2 Case TypeModule.FitType.eRecipCube fXt1 = 1 / m_fX(I) ^ 3 Case TypeModule.FitType.eSqrt fXt1 = Math.Sqrt(m_fX(I)) Case TypeModule.FitType.eRecipSqrt fXt1 = 1 / Math.Sqrt(m_fX(I)) Case TypeModule.FitType.eLn fXt1 = Math.Log(m_fX(I)) End Select Select Case ITX2 Case TypeModule.FitType.eLinear fXt2 = m_fX(I) Case TypeModule.FitType.eSquare fXt2 = m_fX(I) ^ 2 Case TypeModule.FitType.eCube fXt2 = m_fX(I) ^ 3 Case TypeModule.FitType.eCubeRoot fXt2 = m_fX(I) ^ (1 / 3) Case TypeModule.FitType.eRecip fXt2 = 1 / m_fX(I) Case TypeModule.FitType.eRecipCubeRoot fXt2 = 1 / m_fX(I) ^ (1 / 3) Case TypeModule.FitType.eRecipSquare fXt2 = 1 / m_fX(I) ^ 2 Case TypeModule.FitType.eRecipCube fXt2 = 1 / m_fX(I) ^ 3 Case TypeModule.FitType.eSqrt fXt2 = Math.Sqrt(m_fX(I)) Case TypeModule.FitType.eRecipSqrt fXt2 = 1 / Math.Sqrt(m_fX(I)) Case TypeModule.FitType.eLn fXt2 = Math.Log(m_fX(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) m_sTX2 = SayTransform(ITX2) 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) Else m_sTX1 = SayTransform(ITX1) m_sTX2 = SayTransform(ITX2) m_sTY = SayTransform(ITY, "Y") sModel = m_sTY & " - A + B1 * " & m_sTX1 & " + B2 * " & m_sTX2 ' objRes.Add(sModel, -1, 0, 0, 0, 0) 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.