Attribute VB_Name = "eff_size_rank_biserial_os"
'Created by Peter Stikker
'Companion website: https://PeterStatistics.com
'YouTube channel: https://www.youtube.com/stikpet
'Donations welcome at Patreon: https://www.patreon.com/bePatron?u=19398076

Public Sub es_rank_biserial_os_addHelp()
Application.MacroOptions _
    Macro:="es_rank_biserial_os", _
    Description:="Rank biserial correlation coefficient (one-sample)", _
    category:=14, _
    ArgumentDescriptions:=Array( _
        "range with the numeric scores", _
        "optional parameter to set the hypothesized median. If not used the midrange is used")
        
Application.MacroOptions _
    Macro:="es_rank_biserial_os_arr", _
    Description:="Rank biserial correlation coefficient (one-sample)" & vbNewLine & "array function, requires 2 rows and 2 columns as output", _
    category:=14, _
    ArgumentDescriptions:=Array( _
        "range with the numeric scores", _
        "optional parameter to set the hypothesized median. If not used the midrange is used")
        
End Sub

Function es_rank_biserial_os(data As Range, _
                    Optional hypMed = "none")
                    
'calculates a matched pairs rank-biserial coefficient
'data -> vector of scores (numerical)
'hypMed -> optional hypothesized median, if not set midrange will be used

If hypMed = "none" Then
    hypMed = (WorksheetFunction.Min(data) + WorksheetFunction.Max(data)) / 2
End If

Dim n, nr As Integer
n = WorksheetFunction.Count(data)
nr = n - WorksheetFunction.CountIf(data, hypMed)

Dim absDiffs() As Double
ReDim absDiffs(0 To nr - 1)
Dim scores() As Double
ReDim scores(0 To nr - 1)
Dim i, k As Integer
k = 0
i = 1
Do While k < nr
    If WorksheetFunction.IsNumber(data(i)) Then
            If data(i) <> hypMed Then
                absDiffs(k) = Abs(data(i) - hypMed)
                scores(k) = data(i)
                k = k + 1
            End If
    End If
    
    i = i + 1
Loop
    
'sort scores based on absolute differences
changes = 1
Do While changes <> 0
    changes = 0
    For i = 1 To nr - 1
        If absDiffs(i - 1) > absDiffs(i) Then
            ff1 = absDiffs(i)
            ff2 = scores(i)
            absDiffs(i) = absDiffs(i - 1)
            scores(i) = scores(i - 1)
            absDiffs(i - 1) = ff1
            scores(i - 1) = ff2
            
            changes = 1
        End If
    Next i
Loop

'we need the ranks for which we need the rank frequencies
'store for each score how often it occurs
Dim Rfreq As Variant
ReDim Rfreq(1 To nr, 1 To 3)
For i = 0 To nr - 1
    For j = 0 To nr - 1
        If absDiffs(j) = absDiffs(i) Then
            freq = freq + 1
        End If
    Next j
    
    Rfreq(i + 1, 1) = absDiffs(i)
    Rfreq(i + 1, 2) = freq
    freq = 0
Next i

'now for the ranks and sum of ranks
nD0 = 0
Rsum = 0
RsumN = 0
Rd0 = 0 'for sum of ranks of differences of 0
ReDim r(1 To nr, 1 To 3)
r(1, 1) = Rfreq(1, 1)
r(1, 2) = Rfreq(1, 2)

If Rfreq(1, 2) = 1 Then
    r(1, 3) = 1
    Else
    r(1, 3) = (1 + 1 + Rfreq(1, 2) - 1) / 2
End If

If scores(0) > hypMed Then
    Rsum = Rsum + r(1, 3)
ElseIf scores(0) = hypMed Then
    nD0 = nD0 + 1
    Rd0 = Rd0 + r(1, 3)
Else
    RsumN = RsumN + r(1, 3)
End If


For i = 2 To nr
    r(i, 1) = Rfreq(i, 1)
    r(i, 2) = Rfreq(i, 2)
    
    If Rfreq(i, 2) = 1 Then
        r(i, 3) = i
    ElseIf Rfreq(i, 1) <> Rfreq(i - 1, 1) Then
        r(i, 3) = (i + i + Rfreq(i, 2) - 1) / 2
    Else
        r(i, 3) = r(i - 1, 3)
    End If
        
    If scores(i - 1) > hypMed Then
        Rsum = Rsum + r(i, 3)
    ElseIf scores(i - 1) = hypMed Then
        nD0 = nD0 + 1
        Rd0 = Rd0 + r(i, 3)
    Else
        RsumN = RsumN + r(i, 3)
    End If
    
Next i

es_rank_biserial_os = Abs(Rsum - RsumN) / (Rsum + RsumN)

End Function

Function es_rank_biserial_os_arr(data As Range, _
                    Optional hypMed = "none")
                    
'calculates a matched pairs rank-biserial coefficient
'data -> vector of scores (numerical)
'hypMed -> optional hypothesized median, if not set midrange will be used

If hypMed = "none" Then
    hypMed = (WorksheetFunction.Min(data) + WorksheetFunction.Max(data)) / 2
End If

Dim n, nr As Integer
n = WorksheetFunction.Count(data)
nr = n - WorksheetFunction.CountIf(data, hypMed)

Dim absDiffs() As Double
ReDim absDiffs(0 To nr - 1)
Dim scores() As Double
ReDim scores(0 To nr - 1)
Dim i, k As Integer
k = 0
i = 1
Do While k < nr
    If WorksheetFunction.IsNumber(data(i)) Then
            If data(i) <> hypMed Then
                absDiffs(k) = Abs(data(i) - hypMed)
                scores(k) = data(i)
                k = k + 1
            End If
    End If
    
    i = i + 1
Loop
    
'sort scores based on absolute differences
changes = 1
Do While changes <> 0
    changes = 0
    For i = 1 To nr - 1
        If absDiffs(i - 1) > absDiffs(i) Then
            ff1 = absDiffs(i)
            ff2 = scores(i)
            absDiffs(i) = absDiffs(i - 1)
            scores(i) = scores(i - 1)
            absDiffs(i - 1) = ff1
            scores(i - 1) = ff2
            
            changes = 1
        End If
    Next i
Loop

'we need the ranks for which we need the rank frequencies
'store for each score how often it occurs
Dim Rfreq As Variant
ReDim Rfreq(1 To nr, 1 To 3)
For i = 0 To nr - 1
    For j = 0 To nr - 1
        If absDiffs(j) = absDiffs(i) Then
            freq = freq + 1
        End If
    Next j
    
    Rfreq(i + 1, 1) = absDiffs(i)
    Rfreq(i + 1, 2) = freq
    freq = 0
Next i

'now for the ranks and sum of ranks
nD0 = 0
Rsum = 0
RsumN = 0
Rd0 = 0 'for sum of ranks of differences of 0
ReDim r(1 To nr, 1 To 3)
r(1, 1) = Rfreq(1, 1)
r(1, 2) = Rfreq(1, 2)

If Rfreq(1, 2) = 1 Then
    r(1, 3) = 1
    Else
    r(1, 3) = (1 + 1 + Rfreq(1, 2) - 1) / 2
End If

If scores(0) > hypMed Then
    Rsum = Rsum + r(1, 3)
ElseIf scores(0) = hypMed Then
    nD0 = nD0 + 1
    Rd0 = Rd0 + r(1, 3)
Else
    RsumN = RsumN + r(1, 3)
End If


For i = 2 To nr
    r(i, 1) = Rfreq(i, 1)
    r(i, 2) = Rfreq(i, 2)
    
    If Rfreq(i, 2) = 1 Then
        r(i, 3) = i
    ElseIf Rfreq(i, 1) <> Rfreq(i - 1, 1) Then
        r(i, 3) = (i + i + Rfreq(i, 2) - 1) / 2
    Else
        r(i, 3) = r(i - 1, 3)
    End If
        
    If scores(i - 1) > hypMed Then
        Rsum = Rsum + r(i, 3)
    ElseIf scores(i - 1) = hypMed Then
        nD0 = nD0 + 1
        Rd0 = Rd0 + r(i, 3)
    Else
        RsumN = RsumN + r(i, 3)
    End If
    
Next i

rb = Abs(Rsum - RsumN) / (Rsum + RsumN)

'Results
Dim res(1 To 2, 1 To 2)
res(1, 1) = "hyp. med."
res(1, 2) = "rb"
res(2, 1) = hypMed
res(2, 2) = rb

es_rank_biserial_os_arr = res

End Function