Simple Regression Using Gradient Descent (in VBA)

[wellinth]

Gradient descent finds the minimum of a function. It's used in machine learning a lot. I created an Excel macro that uses it find the slope and intercept of a trend line. (The macro uses an algorithm found in Learn under the hood of Gradient Descent algorithm using excel.) See below for the code. If anyone wants, I can send him/her an Excel file that implements this macro.

Hope this helps.

- Tom

Option Explicit

Sub Gradient_Descent()
'Uses gradient descent to estimate the slope and intercept in simple regression
On Error GoTo Err_Handler

Dim xRange As Range, yRange As Range
Dim numxvals As Integer, numyvals As Integer
Dim slope As Double, intercept As Double
Dim cost_function As Double, partial_slope As Double, partial_intercept As Double
Dim maxiter As Integer, tol As Double, alpha As Double
Dim predicted_Ys As Variant, j As Integer, iter As Integer
Dim resid As Double

'Get range of data for regression.  If ranges not compatible or missing
'exit with error

'On Error Resume Next
Set xRange = Application.InputBox(prompt:="Enter x range.", Type:=8)
'On Error GoTo 0

If xRange Is Nothing Then
    MsgBox "Nothing Entered.  Operation Cancelled", vbExclamation
    Exit Sub
End If

Set yRange = Application.InputBox(prompt:="Enter y range.", Type:=8)

If yRange Is Nothing Then
    MsgBox "Nothing Entered.  Operation Cancelled", vbExclamation
    Exit Sub
End If

'number of data points.
numxvals = xRange.Rows.Count
numyvals = yRange.Rows.Count

If numxvals <> numyvals Then
    MsgBox "x Range and y Range have Different numbers.  Try Again.", vbExclamation
    GoTo Clean_Up_and_Exit
End If

If yRange.Columns.Count > 1 Then
   MsgBox "y Range must be one column!  Try Again.", vbExclamation
   GoTo Clean_Up_and_Exit
End If

'Clear ranges.
'Create an array to hold predicted y-values at each iteration.
'Get initial values from spreadsheet.
Range("P:U").Clear


ReDim predicted_Ys(1 To numyvals)

slope = Range("O1").Value
intercept = Range("O2").Value
maxiter = Range("O3").Value
tol = Range("O4").Value
alpha = Range("O5").Value

'Calculate the initial predited values, cost function and partial derivatives of slope and intercept

iter = 1
cost_function = 0
partial_intercept = 0
partial_slope = 0

For j = 1 To numyvals

    predicted_Ys(j) = intercept + (slope * xRange.Cells(j, 1).Value)
    resid = yRange.Cells(j, 1).Value - predicted_Ys(j)
    cost_function = cost_function + resid * resid
    partial_intercept = partial_intercept - resid
    partial_slope = partial_slope - resid * xRange.Cells(j, 1).Value
       
Next j

cost_function = cost_function / 2


'Use the partials to restimate the slope and intercept at each iteration.  Print intermediate results.
'stop after maximum number of iterations reached or cost function error is within the desired tolerance.


Range("P1").Value = "Iteration"
Range("Q1").Value = "Slope of Regression Line"
Range("R1").Value = "Intercept of Regression Line"
Range("S1").Value = "Value of Cost Function"
Range("T1").Value = "Partial of Intercept"
Range("U1").Value = "Partial of Slope"

Do

    Range("P1").Offset(iter, 0).Value = iter
    Range("Q1").Offset(iter, 0).Value = slope
    Range("R1").Offset(iter, 0).Value = intercept
    Range("S1").Offset(iter, 0).Value = cost_function
    Range("T1").Offset(iter, 0).Value = partial_intercept
    Range("U1").Offset(iter, 0).Value = partial_slope
   
   
    intercept = intercept - alpha * partial_intercept
    slope = slope - alpha * partial_slope
   
   
    iter = iter + 1
    cost_function = 0
    partial_intercept = 0
    partial_slope = 0
   
    For j = 1 To numyvals

        predicted_Ys(j) = intercept + slope * xRange.Cells(j, 1).Value
        resid = yRange.Cells(j, 1).Value - predicted_Ys(j)
        cost_function = resid * resid + cost_function
       
        partial_intercept = partial_intercept - resid
        partial_slope = partial_slope - resid * xRange.Cells(j, 1).Value
       
    Next j


    cost_function = cost_function / 2

Loop Until (cost_function <= tol Or iter > maxiter)

'Print final result and exit.
Range("N14").Value = "Estimated Slope:  " & slope
Range("N15").Value = "Estimated Intercept:  " & intercept


Clean_Up_and_Exit:
Set xRange = Nothing
Set yRange = Nothing
Exit Sub

Err_Handler:
If Err.Number = 424 Then
    MsgBox prompt:="Hmmm... Something went wrong. Maybe you clicked cancel by mistake ", _
    Title:="Try Again"
Else
    MsgBox prompt:="Hmmm... Something went wrong." & vbCrLf & _
    "Error Number: " & Err.Number & vbCrLf & _
    "Error Description: " & Err.Description, _
    Title:="Try Again"

End If

GoTo Clean_Up_and_Exit

End Sub