Option Explicit
Private Type POINT
X As Double
Y As Double
End Type
Private Sub Form_Load()
Dim SinglePoints(4) As Double, InTrendPoints() As POINT, OutTrendPoints() As POINT
SinglePoints(0) = 10
SinglePoints(1) = 35
SinglePoints(2) = 50
SinglePoints(3) = 18
SinglePoints(4) = 13
' increase the "ExpandTo" param to have even more precision
InTrendPoints = ExpandPoints(SinglePoints, 60)
'InTrendPoints = ExpandPointsB(SinglePoints, 60) ' a simpler expand...
OutTrendPoints = Trend(InTrendPoints, 3)
Picture1.AutoRedraw = True
DrawTrend Picture1, InTrendPoints, RGB(180, 180, 180)
DrawTrend Picture1, OutTrendPoints, vbBlue
End Sub
Private Sub DrawTrend(Pic As PictureBox, Points() As POINT, ByVal Color As Long, Optional WithPoints As Boolean = False)
Dim MaxY As Double, MaxX As Double, K As Long, EmptySpaceX As Double, EmptySpaceY As Double
For K = 0 To UBound(Points)
If Points(K).X > MaxX Then MaxX = Points(K).X
If Points(K).Y > MaxY Then MaxY = Points(K).Y
Next K
EmptySpaceX = MaxX * 0.1
EmptySpaceY = MaxY * 0.1
Pic.Scale (-EmptySpaceX, MaxY + EmptySpaceY)-(MaxX + EmptySpaceX, -EmptySpaceY)
Picture1.DrawWidth = 1
Pic.Line (-EmptySpaceX, 0)-(MaxX + EmptySpaceX, 0), RGB(128, 128, 128)
Pic.Line (0, MaxY + EmptySpaceY)-(0, -EmptySpaceY), RGB(128, 128, 128)
Picture1.DrawWidth = 2
Pic.PSet (Points(0).X, Points(0).Y), Color
If WithPoints Then
For K = 1 To UBound(Points)
Pic.PSet (Points(K).X, Points(K).Y), Color
Next K
Else
For K = 1 To UBound(Points)
Pic.Line -(Points(K).X, Points(K).Y), Color
Next K
End If
End Sub
Private Function ExpandPointsB(InPoints() As Double, ExpandTo As Long) As POINT()
Dim OutPoints() As POINT, K As Long, Per As Double, X As Long
If ExpandTo <= 2 Then Exit Function
ReDim OutPoints(ExpandTo - 1)
For K = 0 To UBound(OutPoints)
Per = K / CDbl(UBound(OutPoints))
X = Round(UBound(InPoints) * Per)
OutPoints(K).X = K + 1
OutPoints(K).Y = InPoints(X)
Next K
ExpandPointsB = OutPoints
End Function
Private Function ExpandPoints(InPoints() As Double, ExpandTo As Long) As POINT()
Dim OutPoints() As POINT, K As Long, Per As Double, PerX As Double, LngX As Long
If ExpandTo <= 2 Then Exit Function
ReDim OutPoints(ExpandTo - 1)
For K = 0 To UBound(OutPoints) - 1
Per = K / CDbl(UBound(OutPoints))
PerX = UBound(InPoints) * Per
LngX = Fix(PerX)
OutPoints(K).X = K + 1
OutPoints(K).Y = InPoints(LngX) + (InPoints(LngX + 1) - InPoints(LngX)) * (PerX - LngX)
Next K
OutPoints(K).X = K + 1
OutPoints(K).Y = InPoints(UBound(InPoints))
ExpandPoints = OutPoints
End Function
Private Function Trend(Data() As POINT, ByVal Degree As Long) As POINT()
'degree 1 = straight line y=a+bx
'degree n = polynomials!!
Dim a() As Double
Dim Ai() As Double
Dim b() As Double
Dim P() As Double
Dim SigmaA() As Double
Dim SigmaP() As Double
Dim PointCount As Long
Dim MaxTerm As Long
Dim m As Long, n As Long
Dim i As Long, J As Long
Dim Ret() As POINT
Degree = Degree + 1
MaxTerm = (2 * (Degree - 1))
PointCount = UBound(Data) + 1
ReDim SigmaA(MaxTerm - 1)
ReDim SigmaP(MaxTerm - 1)
' Get the coefficients lists for matrices A, and P
For m = 0 To (MaxTerm - 1)
For n = 0 To (PointCount - 1)
SigmaA(m) = SigmaA(m) + (Data(n).X ^ (m + 1))
SigmaP(m) = SigmaP(m) + ((Data(n).X ^ m) * Data(n).Y)
Next
Next
' Create Matrix A, and fill in the coefficients
ReDim a(Degree - 1, Degree - 1)
For i = 0 To (Degree - 1)
For J = 0 To (Degree - 1)
If i = 0 And J = 0 Then
a(i, J) = PointCount
Else
a(i, J) = SigmaA((i + J) - 1)
End If
Next
Next
' Create Matrix P, and fill in the coefficients
ReDim P(Degree - 1, 0)
For i = 0 To (Degree - 1)
P(i, 0) = SigmaP(i)
Next
' We have A, and P of AB=P, so we can solve B because B=AiP
Ai = MxInverse(a)
b = MxMultiplyCV(Ai, P)
' Now we solve the equations and generate the list of points
PointCount = PointCount - 1
ReDim Ret(PointCount)
' Work out non exponential first term
For i = 0 To PointCount
Ret(i).X = Data(i).X
Ret(i).Y = b(0, 0)
Next
' Work out other exponential terms including exp 1
For i = 0 To PointCount
For J = 1 To Degree - 1
Ret(i).Y = Ret(i).Y + (b(J, 0) * Ret(i).X ^ J)
Next
Next
Trend = Ret
End Function
Private Function MxMultiplyCV(Matrix1() As Double, ColumnVector() As Double) As Double()
Dim i As Long
Dim J As Long
Dim Rows As Long
Dim Cols As Long
Dim Ret() As Double
Rows = UBound(Matrix1, 1)
Cols = UBound(Matrix1, 2)
ReDim Ret(UBound(ColumnVector, 1), 0) 'returns a column vector
For i = 0 To Rows
For J = 0 To Cols
Ret(i, 0) = Ret(i, 0) + (Matrix1(i, J) * ColumnVector(J, 0))
Next
Next
MxMultiplyCV = Ret
End Function
Private Function MxInverse(Matrix() As Double) As Double()
Dim i As Long
Dim J As Long
Dim Rows As Long
Dim Cols As Long
Dim Tmp() As Double
Dim Ret() As Double
Dim Degree As Long
Tmp = Matrix
Rows = UBound(Tmp, 1)
Cols = UBound(Tmp, 2)
Degree = Cols + 1
'Augment Identity matrix onto matrix M to get [M|I]
ReDim Preserve Tmp(Rows, (Degree * 2) - 1)
For i = Degree To (Degree * 2) - 1
Tmp(i Mod Degree, i) = 1
Next
' Now find the inverse using Gauss-Jordan Elimination which should get us [I|A-1]
MxGaussJordan Tmp
' Copy the inverse (A-1) part to array to return
ReDim Ret(Rows, Cols)
For i = 0 To Rows
For J = Degree To (Degree * 2) - 1
Ret(i, J - Degree) = Tmp(i, J)
Next
Next
MxInverse = Ret
End Function
Private Sub MxGaussJordan(Matrix() As Double)
Dim Rows As Long
Dim Cols As Long
Dim P As Long
Dim i As Long
Dim J As Long
Dim m As Double
Dim d As Double
Dim Pivot As Double
Rows = UBound(Matrix, 1)
Cols = UBound(Matrix, 2)
' Reduce so we get the leading diagonal
For P = 0 To Rows
Pivot = Matrix(P, P)
For i = 0 To Rows
If Not P = i Then
m = Matrix(i, P) / Pivot
For J = 0 To Cols
Matrix(i, J) = Matrix(i, J) + (Matrix(P, J) * -m)
Next
End If
Next
Next
'Divide through to get the identity matrix
'Note: the identity matrix may have very small values (close to zero)
'because of the way floating points are stored.
For i = 0 To Rows
d = Matrix(i, i)
For J = 0 To Cols
Matrix(i, J) = Matrix(i, J) / d
Next
Next
End Sub