Test non paramétrique de Colin-White (VBA)

MColinWhite.bas

'
' TEST DE COLIN WHITE
'
'       Test non paramétrique de deux échantillons de populations quelconques
'
'       référence: NF X 06-065
'
' René DEVICHI 1998
'
Option Explicit
Option Base 0

Dim valeurs()   As Double
Dim val_src()   As Boolean          ' True pour les valeurs de référence
Dim val_order() As Integer
Dim nbval       As Long
'
' ColinWhite()
'   effectue le test de Colin White entre deux échantillons de taille quelconque
'   Confiance = 1-Risque (<100%)
'   Lateral = "B" ou "G" ou "D" (pour Bilatéral, Gauche, Droite)
'
Public Function ColinWhite(ref As Range, ctl As Range, ByVal Lateral As String, ByVal Confiance As Double) As String
    Dim c           As Excel.Range
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim rang        As Single
    Dim somme_rang  As Single
    Dim n           As Long
    Dim m           As Long
    Dim a           As Double
    Dim s1          As Long
    Dim s2          As Long
    Dim partiel     As String
    

    If Confiance < 0.7 Or Confiance > 1 Then
        ColinWhite = "Erreur de Confiance"
        Exit Function
    End If
    Lateral = UCase(Lateral)
    If Lateral <> "D" And Lateral <> "G" And Lateral <> "B" Then
        ColinWhite = "Erreur de Lateral"
        Exit Function
    End If

    nbval = ref.Cells.Count + ctl.Cells.Count
    ReDim valeurs(0 To nbval - 1)
    ReDim val_src(0 To nbval - 1)
    ReDim val_order(0 To nbval - 1)
    
    ' recopie dans le tableau valeurs() les valeurs de référence et de contrôle
    i = 0
    For Each c In ref.Cells
        If IsNumeric(c.Value) Then
            valeurs(i) = c.Value
            val_src(i) = True
            i = i + 1
        End If
    Next
    For Each c In ctl.Cells
        If IsNumeric(c.Value) Then
            valeurs(i) = c.Value
            val_src(i) = False
            i = i + 1
        End If
    Next
    If i < nbval Then
        nbval = i
        partiel = " **"
    Else
        partiel = ""
    End If
        
    quicksort
    For i = 0 To nbval - 2
        If valeurs(val_order(i)) > valeurs(val_order(i + 1)) Then
            Stop
        End If
    Next
    
    
    somme_rang = 0
    i = 0
    j = 0
    Do
        Do While valeurs(val_order(i)) = valeurs(val_order(j))
            j = j + 1
            If j = nbval Then Exit Do
        Loop
        rang = (1 + i + j) / 2#
        'Debug.Print rang, valeurs(val_order(i))
        For k = i To j - 1
            If val_src(val_order(k)) = False Then       ' valeur de contrôle ?
                somme_rang = somme_rang + rang
            End If
        Next
        i = j
    Loop Until i = nbval
    
    
    If Lateral = "B" Then
        a = Application.WorksheetFunction.NormSInv(1 - (1 - Confiance) / 2)
        
        s1 = Seuil(ref.Cells.Count, ctl.Cells.Count, -a)
        s2 = Seuil(ref.Cells.Count, ctl.Cells.Count, a)
        ColinWhite = CStr((somme_rang >= s1) And (somme_rang <= s2)) & partiel & " (" & s1 & "<=[" & somme_rang & "]<=" & s2 & ")"
        
    ElseIf Lateral = "G" Then
        a = Application.WorksheetFunction.NormSInv(Confiance)
        s1 = Seuil(ref.Cells.Count, ctl.Cells.Count, -a)
        ColinWhite = CStr(somme_rang >= s1) & partiel & " (" & s1 & "<= [" & somme_rang & "])"
        
    ElseIf Lateral = "D" Then
        a = Application.WorksheetFunction.NormSInv(Confiance)
        s2 = Seuil(ref.Cells.Count, ctl.Cells.Count, a)
        ColinWhite = CStr(somme_rang <= s2) & partiel & " ([" & somme_rang & "]<=" & s2 & ")"
    End If
        
    
    Erase val_order
    Erase val_src
    Erase valeurs
        
End Function
'
' Seuil()
'   calcule le seuil pour un échantillon de référence m et de contrôle n.
'
'   a est, pour une confiance (ou probabilité) donnée, la valeur d'une variable
'   aléatoire suivant une loi normale standard (ou centrée réduite). Cette
'   distribution a une moyenne égale à zéro et un écart type égal à 1.
'
Public Function Seuil(ByVal m As Long, ByVal n As Long, ByVal a As Double) As Long

    Seuil = n * (n + m + 1) / 2 + a * Sqr(n * m * (n + m + 1) / 12)
    
End Function
'
' quicksort() - encapsulage de qsort()
'   tri selon l'ordre (route/a0/a1) les tables en utilisant une fonction
'   bijective intermédiaire (on classe valeurs o val_order)
'
Private Sub quicksort()
    Dim i As Integer
    For i = 0 To nbval - 1
        val_order(i) = i
    Next i
    qsort 0, nbval - 1
End Sub
'
' qsort() - fonction de tri quicksort récursif
'   la recursion étant correctement maîtrisée si a < b et la pile très
'   petite (3 integers), la fonction est très efficace
'   par contre, on peut discuter de l'intérêt pour classer de 2 à ~ 5 éléments
'
Private Sub qsort(a As Integer, b As Integer)
    Dim i       As Integer
    Dim j       As Integer
    Dim p       As Integer          ' rang du pivot
    Dim aux     As Integer
        
    i = a
    j = b
    p = (a + b) / 2
    Do
        Do While val_cmp(i, p) < 0
            i = i + 1
        Loop
        Do While j > a And val_cmp(p, j) < 0
            j = j - 1
        Loop
        If i <= j Then
            If i = p Then                   ' trace le rang du pivot
                p = j                       ' (qui peut changer à cet endroit !)
            ElseIf j = p Then
                p = i
            End If
                
            aux = val_order(i)
            val_order(i) = val_order(j)
            val_order(j) = aux
            i = i + 1
            j = j - 1
        End If
    Loop While i <= j
    If a < j Then Call qsort(a, j)
    If i < b Then Call qsort(i, b)
End Sub
'
' val_cmp() - fonction de comparaison pour qsort()
'       retourne -1 si valeurs(val_order(a)) < valeurs(val_order(b))
'                 1 si                       >
'                 0 si                       =
'
Private Function val_cmp(a As Integer, b As Integer) As Integer
    
    If a < 0 Or b < 0 Or a >= nbval Or b >= nbval Then
        MsgBox "erreur...", vbCritical
        End
    End If
    
    val_cmp = Sgn(valeurs(val_order(a)) - valeurs(val_order(b)))
    
End Function