Weighted Percentile -- Amendments to an existing UDF

[Juggler_IN]

I am starting a new thread regarding the UDF at:
weighted percentile

There is a quartile/percentile UDF by Jerry at:
Excel - Interquartile Range Miscalulation

Which is:

Public Function Quartile( _
       ByVal x As Variant, _
       ByVal q As Variant, _
       ByVal m As Variant) As Double
   
    Dim intM%, lngN&, dblP#, dblH#, dblC#, lngH&, dblG#

    lngN = Application.WorksheetFunction.Count(x)
    intM = m
    dblP = q

    Select Case intM
    Case Is = 4
        dblC = CDbl(0#)
    Case Is = 5
        dblC = CDbl(1# / 2#)
    Case Is = 6
        dblC = CDbl(dblP)
    Case Is = 7
        dblC = CDbl(1# - dblP)
    Case Is = 8
        dblC = CDbl((dblP + 1#) / 3#)
    Case Is = 9
        dblC = CDbl((dblP + (3# / 2#)) / 4#)
    Case Else
        dblC = CDbl(dblP)
    End Select

    dblH = lngN * dblP + dblC
    lngH = Fix(dblH)
    If lngH = 0& Then lngH = 1&
    If lngH > lngN Then lngH = lngN
    dblG = dblH - lngH
    If dblG >= 0# And lngH < lngN Then
        Quartile = (1# - dblG) * Application.WorksheetFunction.Small(x, lngH) + dblG * Application.WorksheetFunction.Small(x, lngH + 1#)
    Else
        Quartile = Application.WorksheetFunction.Small(x, lngH)
    End If

End Function

Can this be integrated with the Wt. Percentile UDF:

Function WgtPctileIncIf(rTest As Range, vTest As Variant, _
                        rVal As Range, rWgt As Range, _
                        dPct As Double) As Variant
  ' shg 2018
  ' UDF only

  Dim col           As Collection     ' order statistics: {value, wgt, rank of last item}
  Dim i             As Long
  Dim j             As Long
  Dim dVal          As Double
  Dim iWgt          As Long

  If dPct < 0# Or dPct > 1# Then
    WgtPctileIncIf = "Pct = [0,1]!"

  ElseIf rVal.Rows.Count <> rWgt.Rows.Count Or _
         rVal.Columns.Count <> rWgt.Columns.Count Then
    WgtPctileIncIf = "Inputs!"

  Else
    Set col = New Collection

    With col
      .Add Item:=VBA.Array(-1.79E+308, 0&, 0&)  ' dummy for sorting

      For i = 1 To rVal.Cells.Count
        If rTest.Cells(i).Value = vTest Then
          dVal = rVal.Cells(i).Value2
          iWgt = rWgt.Cells(i).Value2

          If iWgt < 0 Then
            WgtPctileIncIf = "Wgt = [0,]!"
            Exit Function

          ElseIf iWgt > 0 Then
            For j = .Count To 1 Step -1
              ' insertion-sort the values

              Select Case Sgn(dVal - .Item(j)(0))
                Case -1  ' less than; increase rank and continue
                  .Add Item:=VBA.Array(.Item(j)(0), .Item(j)(1), .Item(j)(2) + iWgt), After:=j
                  .Remove j

                Case 0  ' same value; combine
                  .Add Item:=VBA.Array(dVal, .Item(j)(1) + iWgt, .Item(j)(2) + iWgt), After:=j
                  .Remove j
                  Exit For

                Case 1  ' greater; add after
                  .Add Item:=VBA.Array(dVal, iWgt, .Item(j)(2) + iWgt), After:=j
                  Exit For
              End Select
            Next j
          End If
        End If
      Next i

      .Remove 1  ' the temp
    End With

    WgtPctileIncIf = dWgtPctileInc(col, dPct)
  End If
End Function

Function dWgtPctileInc(col As Collection, dPct As Double) As Double
  ' shg 2018
  ' VBA only

  ' https://en.wikipedia.org/wiki/Percentile#Second_variant,_%7F'%22%60UNIQ--postMath-00000047-QINU%60%22'%7F
  ' https://en.wikipedia.org/wiki/Percentile#The_weighted_percentile_method

  ' this should be recoded as a binary search

  Dim SN            As Long    ' total  weight
  Dim x             As Double  ' rank of sought value
  Dim xInt          As Long    ' int(x)
  Dim xFrac         As Double  ' mod(x, 10
  Dim j             As Long    ' index to collection

  With col
    SN = .Item(.Count)(2)
    x = dPct * (SN - 1) + 1
    xInt = Int(x)
    xFrac = x - xInt

    For j = 1 To .Count
      If .Item(j)(2) >= x Then
        If x >= .Item(j)(2) - .Item(j)(1) + 1 Then
          ' it's entirely within the level
          dWgtPctileInc = .Item(j)(0)
        Else
          ' it's between levels
          dWgtPctileInc = .Item(j - 1)(0) * (1 - xFrac) + .Item(j)(0) * xFrac
        End If
        Exit For
      End If
    Next j
  End With
End Function

Such that one is able to pick a method for percentile estimation?

 

[Juggler_IN]

I have a function which is generating a VBA Collection. I want to pass it to another function. Refer the two functions at another tread:
Weighted Percentile -- Amendments to an existing UDF

The function "WgtPctileIncIf" is generating a collection which needs to be the input to function "Quantile." Even doing a Collection to Array and passing the array is not working.

Any thoughts?

 

[RoryA]

Why don't you just pass it as a Collection?

 

[Juggler_IN]

@RoryA;

Not working. If you copy the two functions and change WgtPctileIncIf = dWgtPctileInc(col, dPct) to Quartile(col, dPct, 5) it outputs a VALUE error.

 

[RoryA]

Well, yes, you will need to make some other changes, since for example you can't use the COUNT worksheet function on a collection. (You don't need to anyway as the collection has a Count property)

 

[Juggler_IN]

@RoryA;

I am not familiar with Collections. Can you help with the few changes needed to Quantile function?

 

[RoryA]

Please note that I have merged your threads together since they are clearly basically the same and you'd even lost track yourself of where you should be replying!

 

[RoryA]

The simplest way is probably just to write the contents of the collection to an array:

Public Function Quartile( _
       ByVal col As Collection, _
       ByVal q As Variant, _
       ByVal m As Variant) As Double

   Dim intM%, lngN&, dblP#, dblH#, dblC#, lngH&, dblG#
   Dim x()
   lngN = col.Count
   ReDim x(1 To lngN)
   Dim n As Long
   For n = 1 To lngN
      x(n) = col(n)
   Next
   intM = m
   dblP = q

   Select Case intM
      Case Is = 4
         dblC = CDbl(0#)
      Case Is = 5
         dblC = CDbl(1# / 2#)
      Case Is = 6
         dblC = CDbl(dblP)
      Case Is = 7
         dblC = CDbl(1# - dblP)
      Case Is = 8
         dblC = CDbl((dblP + 1#) / 3#)
      Case Is = 9
         dblC = CDbl((dblP + (3# / 2#)) / 4#)
      Case Else
         dblC = CDbl(dblP)
   End Select

   dblH = lngN * dblP + dblC
   lngH = Fix(dblH)
   If lngH = 0& Then lngH = 1&
   If lngH > lngN Then lngH = lngN
   dblG = dblH - lngH
   If dblG >= 0# And lngH < lngN Then
      Quartile = (1# - dblG) * Application.WorksheetFunction.Small(x, lngH) + dblG * Application.WorksheetFunction.Small(x, lngH + 1#)
   Else
      Quartile = Application.WorksheetFunction.Small(x, lngH)
   End If

End Function

 

[Juggler_IN]

@RoryA; Great this works!

 

[Juggler_IN]

@RoryA; I realized that a three dim collection is getting converted to a one dim array. How can be convert a 3-dim col. to a 3-dim arr.?