Excel seems to hang while running a UDF

[tkpmep]

I created the following UDF to perform a robust regression, and run it
against subsets of data in a column by writing formulas of the
following type:
=INDEX(TheilSenRegression(OFFSET($AZ6,0,0,22,1),OFFSET($AZ6,1,0,22,1)),
1)
=INDEX(TheilSenRegression(OFFSET($AZ7,0,0,22,1),OFFSET($AZ7,1,0,22,1)),
1)
....
=INDEX(TheilSenRegression(OFFSET($AZ57,0,0,22,1),OFFSET($AZ57,1,0,22,1)),
1)


Works like a charm while I have less than about 100 such formulae in
the spreadsheet. Any more, and Excel seems to go into an infinite
loop, and I have to eventually killl it. I then tried copying and
pasting values in 96 of the cells to ensure that it was not getting
overloaded (the algorithm is O(N^2) and it may take a while to
recompute the spreadsheet if there are large numbers of fomulae). Now
there are only 4 cells with formulae in them. But the behaviour does
not change - If I copy one of thse formulae to a fifth cell, Excel
goes into an infinite loop. I have tried creating a new spreadsheet -
same problem. Any thoughts?

Sincerely

Thomas Philips


Public Function TheilSenRegression(x As Range, y As Range)

'This function performs a Theil Sen regression, regressing y on x
'For details, refer to Rand Wilcox - Fundamentals of Modern
Statistical Methods or
'P.K. Sen, Estimates of the Regression Coefficient based on
Kendall's Tau, JASA,v 63,#324, Dec 1968pp. 1379-1389

Dim xx() As Double, yy() As Double, slopes() As Double


Nx = Application.WorksheetFunction.Max(x.Rows.Count,
x.Columns.Count)
Mx = Application.WorksheetFunction.Min(x.Rows.Count,
x.Columns.Count)

Ny = Application.WorksheetFunction.Max(y.Rows.Count,
y.Columns.Count)
My = Application.WorksheetFunction.Min(y.Rows.Count,
y.Columns.Count)


If Nx <> Ny Then
MsgBox ("This routine does not work with two ranges of
different lengths.")
Exit Function

ElseIf Nx = 1 Then
MsgBox ("Each range must be of length 2 or more.")
Exit Function

ElseIf Mx > 1 Then
MsgBox ("This routine handles only univariate regressions.
Choose a single row or column for x")
Exit Function

ElseIf Mx > 1 Then
MsgBox ("This routine handles only univariate regressions.
Choose a single row or column for y")
Exit Function

ElseIf result < 0 Or result > 2 Then
MsgBox ("The third parameter (result) must be 0, 1 or 2")
Exit Function

Else
N = Nx
nC2 = N * (N - 1) / 2
ReDim xx(1 To N)
ReDim yy(1 To N)
ReDim slopes(1 To nC2)

For i = 1 To N
If x.Cells(i).Value = "" Then
MsgBox ("X has one or more blank cells")
Exit Function
Else
xx(i) = x.Cells(i).Value
End If

If y.Cells(i).Value = "" Then
MsgBox ("Y has one or more blank cells")
Exit Function
Else
yy(i) = y.Cells(i).Value
End If

Next

End If


k = 0 'Compute slopes between points with unequal x values
For i = 1 To N - 1
For j = i + 1 To N
If xx(i) <> xx(j) Then
k = k + 1
slopes(k) = (yy(j) - yy(i)) / (xx(j) - xx(i))
End If
Next
Next


ReDim Preserve slopes(1 To k)


TheilSenSlope = Application.WorksheetFunction.Median(slopes)
TheilSenIntercept = Application.WorksheetFunction.Median(yy) -
TheilSenSlope * Application.WorksheetFunction.Median(xx)
TheilSenRegression = Array(TheilSenSlope, TheilSenIntercept)


End Function

 

[Michael Hills]

Sorry, I don't have an answer to your problem, but I think there is an error in your calculation of TheilSenIntercept that I wanted to correct before anyone else copied your code like I did.

I was looking for a Theil-Sen function for excel and found your question. Once I removed all the line breaks added by this web page, it worked for me (I don't have anywhere near 100 formulas), but I found that it gave results that didn't seem right for my data sets. The slope looked good, but the offset didn't always go through the center of the distribution for random datasets, and for curved datasets the result was a line tangential to a curved fit. Based on the wikipedia definition of Theil-Sen, the intercept is the median of (yy(i) - TheilSenSlope * xx(i) for each point), not the median(yy()) - TheilSenSlope * median(x).

When I changed the code, the fit looks much better (very similar to native Excel trendline, but better outlier rejection as expected). I replaced the third-to-last line with:

' Original incorrect code
' TheilSenIntercept = Application.WorksheetFunction.Median
(yy) - TheilSenSlope * Application.WorksheetFunction.Median(xx)



' New corrected code
Dim intercepts() As Double
ReDim intercepts(1 To N)
For i = 1 To N
intercepts(i) = yy(i) - TheilSenSlope * xx(i)
Next
TheilSenIntercept = Application.WorksheetFunction.Median(intercepts())