ExcelBanter - View Single Post - Creating a Custom Excel Function to Calculate Gini Coefficients

wrote...
I'm trying to write a custom function to calculate gini coefficients.
I've been able to use this function when inputted manually:

(Where X is a range)
=SUM(ABS(X-TRANSPOSE(X)))/(2*AVERAGE(X)*((COUNT(X))*(COUNT(X))))

...entered as an array function.

You could shorten this formula by using the fact that
COUNT(X-TRANSPOSE(X)) equals COUNT(X)^2, so

=AVERAGE(ABS(X-TRANSPOSE(X)))/AVERAGE(X)/2

What I am interested in creating is a custom function in Visual Basic.
So far, I've gotten this far:

Function GiniCalculator(Range)
GiniCalculator = WorksheetFunction.Sum(Math.Abs(Range -
WorksheetFunction.Transpose(Range))) / (2 *
WorksheetFunction.Average(Range) * ((WorksheetFunction.Count(Range)) *
(WorksheetFunction.Count(Range))))
End Function

But when I use this function, I just arrive at the #VALUE! error
message. I'm not sure why, but it might has something to do with the
fact the above function is an array function. Does anybody have any
thoughts on how to write a custom function for gini coefficients so it
is not necessary to manually input the array address each time?

Yes, it has everything to do with this needing to be evaluated as an
array formula. The good news is that the Evaluate function
automatically detects when it should evaluate its argument as an array
formula. The following udf works.

Function gini(r As Range) As Double
Dim ra As String, n As Double, d As Double
ra = r.Address(1, 1, xlA1, 1)
n = Evaluate("AVERAGE(ABS(" & ra & "-TRANSPOSE(" & ra & ")))")
d = Evaluate("2*AVERAGE(" & ra & ")")
gini = n / d
End Function

However, this is the type of calculation that would be good to
generalize so it could handle arrays or lists of arguments. Not so
difficult to do that as long as you have another function to convert
arbitrary argument lists into 1D arrays.

Function gini(ParamArray a() As Variant) As Double
Dim n As Double, d As Double
Dim v As Variant, i As Long, j As Long, k As Long

v = ravel(a)
k = UBound(v)

For i = 1 To k
d = d + v(i)
For j = i + 1 To k 'eliminates need to divide by 2
n = n + Abs(v(i) - v(j))
Next j
Next i

gini = n / d / k
End Function

Function ravel(ParamArray a() As Variant) As Variant
Dim w As Variant, x As Variant, y As Variant, z As Variant
Dim k As Long, n As Long
Dim rv() As Variant

For Each w In a

If TypeOf w Is Range Then
k = w.Cells.Count
ReDim Preserve rv(1 To n + k)
For Each x In w.Areas
For Each y In x.Value
n = n + 1
rv(n) = y
Next y
Next x

ElseIf IsArray(w) Then
For Each x In w
If IsArray(x) Then
y = ravel(x) 'RECURSE!
k = UBound(y) 'y is 1-based 1D, so done
ReDim Preserve rv(1 To n + k)
For Each z In y
n = n + 1
rv(n) = z
Next z
Else
n = n + 1
If n = UBound(rv) Then ReDim Preserve rv(1 To 2 *
n)
rv(n) = x
End If
Next x

Else
n = n + 1
If n = UBound(rv) Then ReDim Preserve rv(1 To 2 * n)
rv(n) = w

End If

Next w

If n < UBound(rv) Then ReDim Preserve rv(1 To n)
ravel = rv
End Function