Philben - Ms Access » Numérique

Un meilleur RNG…

philben — Sun, 11 Mar 2012 21:47:59 +0000

En parcourant le web, j’ai lu de nombreuses critiques concernant les générateurs de nombres aléatoires livrés avec les systèmes d’exploitation, les langages de programmation…

Et notre couple Randomize/Rnd que vaut-il ?

Tester un RNG (Random Number Generator) nécessite de lui faire passer une batterie de tests statistiques qui permettent de mesurer leur qualité.
le plus célèbre jeu de tests est DieHards tests de G. Marsaglia mais je me suis amusé à tester notre générateur avec le programme de fourmilab (explications sur les résultats).

Résultats

Entropy = 6.960137 bits per byte.

Optimum compression would reduce the size
of this 11469916 byte file by 12 percent.

Chi square distribution for 11469916 samples is 91767249.86, and randomly
would exceed this value less than 0.01 percent of the times.

Arithmetic mean value of data bytes is 111.6449 (127.5 = random).
Monte Carlo value for Pi is 3.304316894 (error 5.18 percent).
Serial correlation coefficient is -0.036392 (totally uncorrelated = 0.0).

Les résultats démontrent que notre RNG n’est pas à la hauteur de nos espérances…

Si vous avez besoin d’un bon générateur de nombres aléatoires, vous avez deux possibilités :

Récupérer un code VBA existant sur le web
Depuis la fin des années 90, il existe d’excellents algorithmes qui utilisent nativement des variables ‘unsigned long’ voir des ‘unsigned long long’ ce qui ne facilite pas le portage en VBA avec notre type ‘long’…

J’ai quand même péché sur le web deux RNG de qualité.

Le fameux ‘Mersenne twister’ porté ici en VBA.
et ISAAC de qualité cryptographique

Ces deux RNG codés en VBA passent sans problème les tests qualité de Fourmilab.

Exemple avec ISAAC :

Entropy = 7.999985 bits per byte.

Optimum compression would reduce the size
of this 11469916 byte file by 0 percent.

Chi square distribution for 11469916 samples is 236.35, and randomly
would exceed this value 79.31 percent of the times.

Arithmetic mean value of data bytes is 127.4950 (127.5 = random).
Monte Carlo value for Pi is 3.141571792 (error 0.00 percent).
Serial correlation coefficient is -0.000191 (totally uncorrelated = 0.0).

En adapter un…
Je dis bien ‘adapter’ et non ‘programmer’ car se sont des algorithmes très pointus.
Je me suis d’abord penché sur des sources qui utilisaient des variables ‘uint32′ dans le but de simplifier l’adaptation.
Leur qualité dépassait rarement celle de notre Rnd et j’ai du me résoudre à explorer les sources ‘modernes’ qui exploitent les ‘uint64′.
Je me suis intéressé à la méthode MWC ‘Multiply with carry’ de G. Marsaglia tout particulièrement à l’algorithme MWC256.

Voici donc mon adaptation de son code :

'Random number generator - MWC256 - Multiply with Carry
'Author : George Marsaglia
' Reference : http://school.anhb.uwa.edu.au/personalpages/kwessen/shared/Marsaglia03.html
' Period about 2^8222. Uses a static array Q[256] and an initial carry 'c',
' the Q array filled with 256 random 32-bit integers in the calling program
' and an initial carry c<809430660 for the multiply-with-carry operation
'Adapted from C to VBA : Philben - v1.0 - 03/2012
Public Function MWC256_UINT32(Optional ByVal Start As Boolean = False) As Double
Const ULL As Double = 2 ^ 64
Const UL As Double = 2 ^ 32
Static Q(1 To 256) As Variant, c As Variant, a As Variant, i As Integer
Dim t As Variant, v As Variant

If Start Or i = 0 Then
Randomize

'c < 809430660 - 0 <= Rnd < 1 - Marsaglia : c=362436
c = CDec(CLng((809430660 - 2 ^ 12) * Rnd() + 2 ^ 11))
a = CDec(809430660)

For i = 1 To 256
Q(i) = CLng(Rnd() * (2 ^ 31 - 1))
Next i

'warm up
Do
MWC256_UINT32
Loop Until i = 256
End If

i = i + 1
If i > 256 Then i = 1

v = a * Q(i) + c
t = CDec(v - Int(v / ULL) * ULL)
c = CDec(Int(t / UL))
Q(i) = v - Int(v / UL) * UL

MWC256_UINT32 = Q(i)
End Function

'Signed integer : (-2^31 to 2^31-1) ?
'author : philben
Public Function MWC256_INT32(Optional ByVal Start As Boolean = False) As Long
MWC256_INT32 = CLng(MWC256_UINT32(Start) - &H7FFFFFFF)
End Function

'Double : (0.0, 1.0) ?
'author : philben - v1.01
Public Function MWC256_Dbl(Optional ByVal Start As Boolean = False) As Double
MWC256_Dbl = MWC256_UINT32(Start) * 2.32830643653869E-10
End Function

et le résultat des tests :

Entropy = 7.999985 bits per byte.

Optimum compression would reduce the size
of this 11469916 byte file by 0 percent.

Chi square distribution for 11469916 samples is 245.85, and randomly
would exceed this value 64.83 percent of the times.

Arithmetic mean value of data bytes is 127.4586 (127.5 = random).
Monte Carlo value for Pi is 3.144400759 (error 0.09 percent).
Serial correlation coefficient is -0.000303 (totally uncorrelated = 0.0).

Il semble que cette adaptation fonctionne bien et à l’avantage d’être plus rapide que les deux précédentes mais beaucoup plus lente que son équivalent en C et que Rnd…
Pour avoir un ordre d’idée, compter moins de 2 secondes par million de nombres générés.

Un autre inconvénient de mon portage est qu’il n’est validé que par moi (!) et je ne suis pas particulièrement fier de l’initialisation de l’algorithme…

Philippe

Fonctions Min / Max d’une série de valeurs

philben — Sun, 11 Mar 2012 20:57:10 +0000

Deux petites fonctions qui permettent d’extraire la valeur minimale ou maximale d’une série de valeurs dans une requête SQL ou dans un code VBA.

Les fonctions

Public Function getMin(ParamArray pa() As Variant) As Variant
Dim v As Variant
For Each v In pa
If getMin > v Then
getMin = v
ElseIf IsEmpty(getMin) And Not IsNull(v) Then
getMin = v
End If
Next v
End Function

Public Function getMax(ParamArray pa() As Variant) As Variant
Dim v As Variant
For Each v In pa
If getMax < v Then
getMax = v
ElseIf IsEmpty(getMax) And Not IsNull(v) Then
getMax = v
End If
Next v
End Function

Paramètre
Elles acceptent un nombre quelconque de valeurs en paramètre grâce à l’utilisation du type ParamArray.

Particularités

Ces fonctions gèrent les NULL c’est à dire qu’elles ne renvoient un NULL que si toutes les valeurs passées en paramètre sont nulles.
Le type des paramètres doit être uniforme et peut être numérique, date ou string. Une adaptation du code sera nécessaire pour une bonne gestion des accents et autres caractères particuliers.

Exemples

'Pas d'erreur si aucun paramètre...
? getMax(), getMin()

'Renvoient 0 :
? getMax(NULL, 0, NULL), getMin(NULL, 0, NULL)

'Renvoient 5 et -1
? getMax(NULL, 0, 5, -1, NULL), getMin(NULL, 0, 5, -1, NULL)

Philippe

Trouver la Nième plus petite valeur d’un tableau

philben — Tue, 17 Jul 2012 00:05:14 +0000

On a souvent besoin de trouver la valeur mini ou maxi d’un tableau de valeurs numériques mais plus rarement la 10ème plus petite valeur, la 10 000 000ème… Je vous présente ici une implémentation en VBA d’un algorithme tout en un, d’une rare simplicité qui sélectionne en une fraction de seconde la valeur du rang désiré.

L’algorithme
Cet algorithme, tout comme le célèbre quicksort, est basé sur le partitionnement du tableau de valeurs. Il est dû à Zabrodsky qui améliora sensiblement un algo proposé par N. Wirth (1976).

Voici mon implémentation en VBA de l’algorithme de Zabrodsky dans le cas d’un tableau d’entiers long:

Public Function KthSmallest(ByRef a() As Long, ByVal k As Long) As Long
'http://dhost.info/zabrodskyvlada/3alg.html
'implementation in VBA by Philben - v1.0
Dim x As Long, tmp As Long
Dim i As Long, j As Long, l As Long, r As Long

l = LBound(a)
r = UBound(a)
While l < r
x = a(k)
i = l
j = r
Do Until j < k Or k < i
While a(i) < x: i = i + 1: Wend
While x < a(j): j = j - 1: Wend
tmp = a(i): a(i) = a(j): a(j) = tmp
i = i + 1
j = j - 1
Loop
If j < k Then l = i
If k < i Then r = j
Wend
KthSmallest = a(k)
End Function

Il existe de nombreux autres algorithmes (selectSmallest in Numerical Recipes, findElementAtRank, quickSelect, …) et vous trouverez ici une publication sur le sujet.

Paramètres de la fonction
Le premier paramètre est le tableau des valeurs et le deuxième (k) est le rang pour lequel on souhaite connaître la valeur associée.

Par exemple, le minimum d’un tableau est recherché par k = 1 si l’indice le plus faible du tableau est 1, et plus généralement avec k = LBound(MonTableau).
Le maximum du tableau est recherché avec k = UBound(MonTableau) et la 10ème plus petite valeur avec k = 10 (si LBound(MonTableau)=1).

Exemple
Soit un tableau de base 1 contenant les valeurs 5, 3, 7, 1, 5.
L’algo retournera :

1 pour k = 1
3 pour k = 2
5 pour k = 3 (médiane des valeurs) et k = 4
7 pour k = 5

Comment faire si mon tableau est de type Double par exemple ?
Il suffit de modifier certains types de variable en DOUBLE et le type retourné par la fonction :

Public Function KthSmallest(ByRef a() As DOUBLE, ByVal k As Long) As DOUBLE
Dim x As DOUBLE, tmp As DOUBLE
...

Vérification de l’implémentation en VBA
La fonction suivante permet de vérifier succinctement que l’algorithme remplit bien sa mission.
Vous pouvez modifier à votre guise les constantes cMinIndice, cMaxIndice.

Pour l’utiliser, copier l’ensemble du code dans un module VBA, placer le focus dans la fonction puis appuyer sur ‘F5‘ pour l’exécuter. Les résultats s’affichent dans la fenêtre ‘Exécution’ (Ctrl+G)

Public Function TestQualiteKth()
'Plus le nombre d'indices est élevé (cMaxIndice - cMinIndice + 1), plus la fonction prend du temps...
'Pour 1000 indices par exemple, elle teste alors 4000 tableaux de 1000 indices...
'Tester aussi bien un nombre d'indices pair et impair
Const cMinIndice As Long = 1 'Indice mini du tableau (= à l'indice mini)
Const cMaxIndice As Long = 1000
Dim a() As Long, aBackup() As Long, n As Long, r As Long

ReDim a(cMinIndice To cMaxIndice)
ReDim aBackup(cMinIndice To cMaxIndice)

'Test n°1 : Tableau de valeurs croissantes
'Chaque indice correspond à sa valeur (a(1)=1, a(2)=2,...)
'La Nième valeur est égale au Nième indice
For n = cMinIndice To cMaxIndice: a(n) = n: Next n
aBackup = a 'un tableau dynamique peut être copié comme une variable simple contrairement à un tableau statique
For n = cMinIndice To cMaxIndice
r = KthSmallest(a, n)
If r <> n Then Debug.Print "Test n°1", "Erreur pour n=", n, "Résultat=", r
a = aBackup
Next n

'Test n°2 : Tableau de valeurs décroissantes
'Chaque indice correspond à sa valeur opposée (a(cMinIndice)=cMaxIndice, a(cMinIndice+1)=cMaxIndice-1,...)
'La Nième valeur est égale au Nième indice
For n = cMinIndice To cMaxIndice: a(n) = cMaxIndice - n + cMinIndice: Next n
aBackup = a
For n = cMinIndice To cMaxIndice
r = KthSmallest(a, n)
If r <> n Then Debug.Print "Test n°2", "Erreur pour n=", n, "Résultat=", r
a = aBackup
Next n

'Test n°3 : Tableau de valeurs identiques sauf une
'Toutes les valeurs sauf une (=1) sont égales à 0
'Tous les résultats sont égaux à 0 sauf pour le dernier indice (=1)
Randomize
For n = cMinIndice To cMaxIndice: a(n) = 0: Next n
aBackup = a
For n = cMinIndice To cMaxIndice
a(Int((cMaxIndice - cMinIndice + 1) * Rnd() + cMinIndice)) = 1
r = KthSmallest(a, n)
If (n < cMaxIndice And r <> 0) Or (n = cMaxIndice And r <> 1) Then Debug.Print "Test n°3", "Erreur pour n =", n, "Résultat =", r
a = aBackup
Next n

'Test n°4 : Tableau de valeurs identiques sauf une
'Toutes les valeurs sauf une (=0) sont égales à 1
'Tous les résultats sont égaux à 1 sauf pour le premier indice (=0)
For n = cMinIndice To cMaxIndice: a(n) = 1: Next n
aBackup = a
For n = cMinIndice To cMaxIndice
a(Int((cMaxIndice - cMinIndice + 1) * Rnd() + cMinIndice)) = 0
r = KthSmallest(a, n)
If (n > cMinIndice And r <> 1) Or (n = cMinIndice And r <> 0) Then Debug.Print "Test n°4", "Erreur pour n =", n, "Résultat =", r
a = aBackup
Next n

Debug.Print "*** fin ***"
End Function

Performance de l’algorithme
La fonction suivante permet de tester la performance de l’algorithme sur un tableau de 10 000 000 de valeurs !
Si vous souhaitez réduire la taille du tableau, il faut alors jouer sur la constante ‘cMaxIndice’. Pour modifier le rang de la valeur à trouver, modifier la constante ‘cNiemeValeur’ qui doit être comprise obligatoirement entre 1 et ‘cMaxIndice’

Pour déterminer la durée de traitement de l’algorithme, on utilise l’API timeGetTime. Il faut donc ajouter la ligne suivante en tête du module VBA :

Option Compare Database
Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Copier l’ensemble du code suivant dans le module VBA où l’API est déclarée, placer le focus dans la fonction puis appuyer sur ‘F5‘ pour l’exécuter. Les résultats s’affichent dans la fenêtre ‘Exécution’ (Ctrl+G)

Public Function TestPerformanceKth()
Const cMaxIndice As Long = 10 ^ 7 'Nombre maximum d'indices du tableau (10^7 = 10 000 000)
Const cMaxValeur As Long = 10 ^ 8 'Valeur maxi

Const cNiemeValeur As Long = 10 ^ 3 'Nième valeur retournée doit être comprise entre 1 <= cNiemeValeur <= cMaxIndice

Dim a() As Long, i As Long, r As Long, t As Long
Dim s As String

Randomize
ReDim a(1 To cMaxIndice)
For i = 1 To cMaxIndice
a(i) = Rnd() * cMaxValeur
Next i

Debug.Print "Départ..."
t = timeGetTime
r = KthSmallest(a, cNiemeValeur)
'r = FindMini(a) 'recherche seulement la valeur mini
t = timeGetTime - t
s = Switch(cNiemeValeur = 1, "plus petite valeur est : ", _
cNiemeValeur < cMaxIndice, cNiemeValeur & "ème plus petite valeur est : ", _
True, "plus grande valeur est : ")
Debug.Print vbTab & "La " & s & r, "- Temps écoulé : " & t & " ms", vbNewLine & "Fin"

End Function

Avec mon système et ces paramètres, l’algorithme retourne le résultat du 1000ème rang entre 250ms et 750ms (plus ou moins de swap et de comparaisons selon les nombres aléatoires générés).

En paramétrant la constante ‘cNiemeValeur’ à 1 pour obtenir la plus petite valeur du tableau, vous pouvez comparer la performance de l’algorithme avec la fonction suivante :

Public Function FindMini(ByRef a() As Long) As Long
Dim i As Long, k As Long, x As Long

k = LBound(a)
x = a(k)
For i = k + 1 To UBound(a)
If a(i) < x Then x = a(i)
Next i
FindMini = x
End Function

Comme vous pouvez le constater, les temps sont très proches dans ce cas de figure (temps en O(N)) et la recherche de la valeur maximale du tableau est tout aussi rapide…

Points faibles de l’algorithme
L’ordre des éléments du tableau d’origine est modifié. Si nécessaire, travailler avec une copie du tableau ou utiliser l’algorithme quickselect.

De plus, lorsque toutes les valeurs du tableau sont identiques, le temps d’exécution devient alors beaucoup plus long.

Philippe

Somme exacte en double précision

philben — Mon, 13 Aug 2012 09:46:48 +0000

Certaines sommes en double précision sont entâchées d’erreurs d’arrondi (round-off error) qui peuvent fausser significativement les résultats. Je vous présente un algorithme qui compense ces erreurs.

La fonction en VBA

Public Function SommeExacte(ByVal s As Double, ByVal x As Double, ByRef c As Double) As Double
'Algorithme de Shewchuk / Knuth - TwoSum()
Dim y As Double, z As Double
y = s + x
z = y - x
c = c - ((z - s) + ((y - z) - x))
SommeExacte = y
End Function

On passe en argument à cette fonction la somme courante (s), la valeur à ajouter (x) et le troisième argument est la variable passée en référence qui contiendra la correction à appliquer après les sommes.
La fonction retourne la somme non corrigée.

Test
Pour tester l’efficacité de la correction, on compare le résultat obtenu avec celui de la somme en type décimal. Pour rappel, le type decimal n’est pas la solution universelle car la plage des nombres est limitée et sa vitesse est lente.

Public Function TestSomme()
Const cNbBoucle As Long = 1000000
Dim v As Variant, i As Long
Dim x As Double, s As Double, c As Double

v = CDec(0)
x = 0.1
c = 0
For i = 1 To cNbBoucle
s = SommeExacte(s, x, c)
v = v + x
Next i
Debug.Print "Somme (decimal):" & v, "Somme:" & s, "Somme exacte:" & (s + c)
End Function

La somme naïve en double précision (s = s + x) reste beaucoup plus rapide que la somme exacte qui sera donc réservée aux cas l’exigeant.

Philippe

Approximer, en double précision, la loi normale gaussienne et son inverse

philben — Sat, 04 Aug 2012 08:38:53 +0000

Je vous propose deux fonctions en VBA pour Access qui estiment la loi normale (ou loi de Laplace-Gauss) et son inverse en double précision. Pour rappel, Excel propose en standard ces fonctions (NORMDIST, NORMINV, NORMSDIST, NORMSINV) et des fonctions encore plus précises depuis Excel 2010 (NORM_DIST, NORM_INV, NORM_S_DIST, NORM_S_INV).

Loi normale
Cette fonction permet de trouver la probabilité cumulée (aire sous la courbe de la distribution gaussienne) d’une variable aléatoire X.
Pour ce faire, je me suis appuyé sur l’un des meilleurs algorithmes (dixit G. Marsaglia) pour calculer la fonction d’erreur complémentaire qui permet d’exprimer la fonction de répartition de la loi normale.
Cet algorithme est dû à Takuya OOURA (1996) que j’ai implémenté en VBA :

Public Function derfc(ByVal X As Double) As Double
'Complementary error function in double precision
'http://www.kurims.kyoto-u.ac.jp/~ooura/index.html
'Copyright(C) 1996 Takuya OOURA : You may use, copy, modify this code for any purpose and without fee.
'Implementation en VBA par Philben - v1.0

Const C0 As Double = 1.27109764952614E-03 + 9.2E-19, C1 As Double = 1.1931402283834E-04 + 9.44E-19, _
C2 As Double = 3.96385097360513E-03 + 5E-18, C3 As Double = 8.70779635317295E-04 + 8.28E-19, _
C4 As Double = 7.73672528313526E-03 + 6.68E-18, C5 As Double = 3.83335126264887E-03 + 3.03E-18, _
C6 As Double = 1.27223813782122E-02 + 7.55E-17, C7 As Double = 0.013382364453346 + 6.9E-18, _
C8 As Double = 1.61315329733252E-02 + 2.48E-17, C9 As Double = 3.90976845588484E-02 + 3.5E-18, _
C10 As Double = 2.49367200053503E-03 + 3.04E-18
Const C11 As Double = 8.38864557023001E-02 + 9.92E-17, C12 As Double = 0.119463959964325 + 4.15E-16, _
C13 As Double = 1.66207924969367E-02 + 3.56E-17, C14 As Double = 0.357524274449531 + 4.3E-17, _
C15 As Double = 0.80527640875291 + 5.67E-16, C16 As Double = 1.18902982909273 + 3.33E-15, _
C17 As Double = 1.37040217682338 + 1.67E-15, C18 As Double = 1.31314653831023 + 9.8E-16, _
C19 As Double = 1.07925515155856 + 6.77E-15, C20 As Double = 0.774368199119538 + 6.09E-16, _
C21 As Double = 0.490165080585318 + 4.24E-16, C22 As Double = 0.275374741597376 + 7.82E-16
Dim t As Double, u As Double, y As Double

t = 3.97886080735226 / (Abs(X) + 3.97886080735226)
u = t - 0.5
y = (((((((((C0 * u + C1) * u - C2) * u - C3) * u + C4) * u + C5) * u - C6) * u - C7) * u + C8) * u + C9) * u + C10
y = ((((((((((((y * u - C11) * u - C12) * u + C13) * u + C14) * u + C15) * u + C16) * u + C17) * u + C18) * u + C19) * _
u + C20) * u + C21) * u + C22) * t * Exp(-X * X)
If X < 0 Then derfc = 2 - y Else: derfc = y
End Function

La précision de la version VBA est certainement moins bonne que la version en C de Takura Ooura car il utilise des constantes avec plus de 15 chiffres significatifs. En effet, VBA n’affiche que 15 chiffres pour le type Double bien qu’il conserve en faite 16 chiffres en interne…
Pour cette raison, chaque constante est définie comme la somme de deux nombres pour conserver ce 16ème chiffre de précision.

La fonction VBA pour calculer la loi normale est :

'---------------------------------------------------------------------------------------
' Procédure : LoiNormale [Function]
' Auteur : Philben - Free to use
' Retour : Double
' Version : 2.0
' Objet : Détermine la probabilité cumulée ou non d'une distribution normale en fonction
' : d'une variable X, de la moyenne et de l'écart-type de la distribution
' Historique : v2.0 : Double précision (07/2012)
' v1.0 : Simple précision (07/2007)
'---------------------------------------------------------------------------------------
Public Function LoiNormale(ByVal X As Double, _
Optional ByVal Esperance As Double = 0, _
Optional ByVal EcartType As Double = 1, _
Optional CumulProbabilite As Boolean = True) As Double
If EcartType <= 0 Then
LoiNormale = -1
Else
If CumulProbabilite Then
LoiNormale = derfc((Esperance - X) / (EcartType * Sqr(2))) * 0.5
Else
X = (X - Esperance) / EcartType
LoiNormale = Exp(-X * X * 0.5) / (EcartType * Sqr(8 * Atn(1)))
End If
End If
End Function

Les paramètres sont la variable aléatoire X pour laquelle on cherche la probabilité correspondante, l’espérance de la distribution (moyenne mu), l’écart-type de la distribution (standard deviation in english) et ‘CumulProbabilite’ un booléen à vrai (par défaut) si on souhaite obtenir la probabilité cumulée de la fonction de répartition.
Par défaut, l’espérance est 0 et l’écart-type à 1 ce qui correspond aux paramètres la loi normale centrée réduite (ou standard) N(0,1) d’espérance égale à 0 et de variance égale à 1.

Loi normale inverse
Cette fonction permet de trouver la variable aléatoire X associée à une probabilité cumulée. Ooura propose aussi un algorithme qui calcul l’inverse de la fonction d’erreur complémentaire qui permet d’obtenir des résultats meilleurs qu’une recherche par bisection avec la fonction derfc.

Public Function dierfc(ByVal y As Double) As Double
'Inverse of complementary error function in double precision
'http://www.kurims.kyoto-u.ac.jp/~ooura/index.html
'Copyright(C) 1996 Takuya OOURA : You may use, copy, modify this code for any purpose and without fee.
'Implementation en VBA par Philben - v1.0

Const C0 As Double = 1.12648096188977E-03 + 9.22E-18, C1 As Double = 1.05739299623423E-04 + 4.7E-20, _
C2 As Double = 0.003512871461291 + 2.5E-19, C3 As Double = 7.7170835895412E-04 + 9.39E-19, _
C4 As Double = 6.85649426074558E-03 + 6.12E-18, C5 As Double = 3.39721910367775E-03 + 8.61E-18, _
C6 As Double = 1.12749169332504E-02 + 8.7E-17, C7 As Double = 1.18598117047771E-02 + 1.04E-17, _
C8 As Double = 1.42961988697898E-02 + 1.8E-18, C9 As Double = 3.46494207789099E-02 + 9.22E-17, _
C10 As Double = 2.20995927012179E-03 + 6.7E-19
Const C11 As Double = 7.43424357241784E-02 + 8.61E-17, C12 As Double = 0.105872177941595 + 4.88E-16, _
C13 As Double = 1.47297938331485E-02 + 1.21E-17, C14 As Double = 0.316847638520135 + 9.44E-16, _
C15 As Double = 0.71365763586873 + 3.64E-16, C16 As Double = 1.05375024970847 + 1.38E-15, _
C17 As Double = 1.21448730779995 + 2.37E-15, C18 As Double = 1.1637458193156 + 8.31E-15, _
C19 As Double = 0.956464974744799 + 6E-18, C20 As Double = 0.686265948274097 + 8.16E-16, _
C21 As Double = 0.43439749233143 + 1.15E-16, C22 As Double = 0.24404451059319 + 9.35E-16, _
C23 As Double = 0.120782237635245 + 2.22E-16

Dim s As Double, t As Double, u As Double, w As Double, X As Double, z As Double

If y > 1 Then z = 2 - y Else: z = y
w = 0.916461398268964 - Log(z)
u = Sqr(w)
s = (Log(u) + 0.488826640273108) / w
t = 1 / (u + 0.231729200323405)
X = u * (1 - s * (s * 0.124610454613712 + 0.5)) - ((((-7.28846765585675E-02 * t + 0.269999308670029) * _
t + 0.150689047360223) * t + 0.116065025341614) * t + 0.499999303439796) * t
t = 3.97886080735226 / (X + 3.97886080735226)
u = t - 0.5
s = (((((((((C0 * u + C1) * u - C2) * u - C3) * u + C4) * u + C5) * u - C6) * u - C7) * u + C8) * u + C9) * u + C10
s = ((((((((((((s * u - C11) * u - C12) * u + C13) * u + C14) * u + C15) * u + C16) * u + C17) * u + _
C18) * u + C19) * u + C20) * u + C21) * u + C22) * t - z * Exp(X * X - C23)
X = X + (s * (X * s + 1))
If y > 1 Then dierfc = -X Else: dierfc = X
End Function

La fonction VBA pour calculer l’inverse de la loi normale :

'---------------------------------------------------------------------------------------
' Procédure : LoiNormaleInverse [Function]
' Auteur : Philben - Free to use
' Retour : Double
' Version : 2.0
' Objet : Détermine la variable X d'une distribution normale en fonction de
' : sa probabilité cumulée Pc, de la moyenne et de l'écart-type de la distribution
' Historique : v2.0 : Double précision (07/2012)
' v1.0 : Simple précision (07/2007)
'---------------------------------------------------------------------------------------
Public Function LoiNormaleInverse(ByVal Pc As Double, _
Optional ByVal Esperance As Double = 0, _
Optional ByVal EcartType As Double = 1) As Double
If Pc <= 0 Then
LoiNormaleInverse = -99
ElseIf Pc >= 1 Then
LoiNormaleInverse = 99
Else
LoiNormaleInverse = (-dierfc(Pc * 2) * EcartType * Sqr(2)) + Esperance
End If
End Function

Les paramètres sont la probabilité cumulée, l’espérance et l’écart-type de la distribution gaussienne pour lesquels on recherche X.

Précision des résultats
Par comparaison avec les résultats de la fonction Excel NORM_S_DIST (notre référence Excel 2010) sur la plage de valeurs entre -8 et 8 de la loi normale standard avec un incrément de 1E-05, la plus grande différence relevée est de 2,220E-16 et une erreur relative maximum de 1,490E-14.

Exemples
Coller l’ensemble des fonctions dans un module standard VBA. Dans la fenêtre d’exécution de l’éditeur visual basic (CTRL + G pour la faire apparaître) coller la ou les lignes d’exemples qui commence par ?, mettre le focus sur la ligne à exécuter puis appuyer sur la touche ‘Entrée’ pour voir le résultat.

Quelle est la probabilité pour qu’une variable aléatoire X soit inférieure ou égale à 14 si elle suit la loi normale N(10,16) (espérance = 10 et variance = 16) ?
L’aire sous la courbe de couleur bleue est la probabilité attendue :

Sachant que l’écart-type est la racine carrée de la variance :

'Probabilité attendue : 0.841344746068543[/cci]
?LoiNormale(14,10,SQR(16))

Remarque : La loi normale est une loi continue de – l’infini à + l’infini et la probabilité que X soit égal à une valeur est pratiquement nulle (P(X = 14) = 0). Donc P(X <= 14) = P(X < 14). Inversément, comment retrouver la variable X de cette probabilité ?

'X attendu : 14
?LoiNormaleinverse(0.841344746068543,10,sqr(16))

Quelle est la probabilité complémentaire de X : P(X > 14) (Aire verte de la courbe) ?
La loi normale est une loi symétrique, on peut donc écrire :

'Probabilité attendue : 0.158655253931457
?1-LoiNormale(14,10,sqr(16))

ou encore :

'Probabilité attendue : 0.158655253931457
?LoiNormale(10-(14-10),10,SQR(16))

Cette deuxième écriture est plus simple dans le cas d’une loi normale centrée réduite N(0,1) :
Exemple pour la probabilité complémentaire de X = 2 (P = 0.977249868051821 et 1-P = 2.27501319481792E-02)

'Probabilité attendue : 2,27501319481792E-02
?LoiNormale(-2)

Remarque : Sous certaines conditions, la loi normale permet d’approximer les lois de Poisson et Binomiale.

Quelle est la probabilité que 7 <= X <= 9 sachant que X suit une loi normale N(8;2,25) (espérance = 8 et variance = 2,25) ?
La probabilité recherchée est l’aire de la courbe verte :

Dans cet exemple, les écarts à l’espérance sont symétrique (7 + 1 = 8 et 9 – 1 = 8) on peut écrire :

'Probabilité attendue : 0.495014924906154
?2*loinormale(9,8,sqr(2.25))-1
'Probabilité attendue : 0.495014924906154
?1-2*loinormale(7,8,sqr(2.25))

Dans le cas général, il faut soustraire les deux probabilités. Par exemple pour 3 <= X <= 7 sachant que X suit une loi normale N(8;9), la formule devient :

'Probabilité attendue : 0.321650987908949
?loinormale(7,8,3)-loinormale(3,8,3)

Exactitude des résultats
L’objectif est d’étudier succinctement l’exactitude des résultats fournis par les fonctions Excel et les fonctions décrites ci-dessus.
Pour ce faire je me suis servi comme référence des probabilités cumulées fournies par Maple 7 de la loi normale standard (avec plus de 16 chiffres significatifs) pour Z<=-1, Z<=-2, Z<=-3, ..., Z<=-37 Le 1er graphe affiche l'erreur relative commise sur l'approximation des probabilités en fonction de Z. L'ordonnée est exprimée en log10 des erreurs relatives. Par exemple, le calcul de l'ordonnée avec la fonction Excel 2010 pour Z = -1 est :

'Résultat attendu : 15.489451329628
-Log(Abs(WorksheetFunction.Norm_S_Dist(-1, True) - (0.158655253931457 + 5.141E-17))/ (0.158655253931457 + 5.141E-17)) / Log(10)

En pratique, il faut vérifier que la différence soit supérieure à zéro car Log(0) provoque une erreur…

Théoriquement, la valeur maximale est 16 lorsqu’il n’existe aucune différence entre les deux valeurs car le type Double a une précision de 16 chiffres (15 visibles + 1) : -Log(1E-16 / 1) / Log(10). Si on ne considère que les 15 chiffres visibles, l’exactitude est déjà parfaite pour une valeur de 15.

En résumé, plus la valeur du log de l’erreur relative est élevée plus le résultat est exact.

Les résultats entre Excel et Access sont très proches.

Le 2ème graphe affiche l’erreur relative commise sur l’approximation de z en fonction des probabilités pour comparer les fonctions Norm_S_Inv() d’Excel 2010 et LoiNormaleInverse().

Les résultats entre Excel et Access sont très proches, on peut noter une petite faiblesse d’Excel sur l’approximation de z pour la 1ère probabilité (z=-1 théoriquement).

Philippe

Générer des nombres aléatoires gaussiens

philben — Mon, 30 Jul 2012 18:01:55 +0000

Je vous présente ici deux petites fonctions écrites en VBA qui permettent de générer des nombres pseudo-aléatoires à distribution normale. Une fonction de visualisation accompagne le tout.

La 1ère méthode implémentée est celle de Box-Muller

Public Function NormalRandomBM(Optional ByVal Esperance As Double = 0, _
Optional ByVal EcartType As Double = 1, _
Optional ByVal ForceRandomize As Boolean = False) As Double
'Générateur de nombres pseudo-aléatoires à distribution normale selon la méthode de Box-Muller - Forme polaire
'Référence : http://en.wikipedia.org/wiki/Box%E2%80%93Muller_transform
'Implementation en VBA par Philben - v1.1 - Free to use
Static isRandomize As Boolean, isNextRandom As Boolean, nextRandom As Double
Dim u As Double, v As Double, s As Double

If Not isRandomize Or ForceRandomize Then
Randomize
isRandomize = True
End If

If isNextRandom Then
NormalRandomBM = Esperance + (nextRandom * EcartType)
Else
Do
u = Rnd() * 2 - 1 'nombres aléatoires entre -1 et 1
v = Rnd() * 2 - 1
s = u ^ 2 + v ^ 2
Loop Until s > 0 And s < 1
s = Sqr(-2 * Log(s) / s)

nextRandom = v * s
NormalRandomBM = Esperance + (u * s * EcartType)
End If
isNextRandom = Not isNextRandom
End Function

Particularité
Cet algorithme génère deux nombres pseudo-aléatoires gaussiens d’où la possibilité d’en conserver un pour l’appel suivant de la fonction.
On conserve un des deux nombres générés dans une variable Static qui sera utilisée au prochain appel pour réduire le temps de calcul de la fonction.

Paramètres de la fonction de Box-Muller
Le premier paramètre est la moyenne mu ou l’espérance de la distribution normale.
Le deuxième est l’écart-type de la distribution gaussienne (doit être supérieur à 0)
Par défaut, l’espérance est égale à 0 et l’écart-type à 1 ce qui correspond aux paramètres de la loi normale centrée réduite N(0;1).
Le troisième paramètre (par défaut à faux) permet de forcer la réinitialisation du générateur de nombre aléatoires de VBA (Randomize). Dans tous les cas, le premier appel de la fonction lance Randomize. Cette première initialisation est sauvegardée dans la variable Static isRandomize qui passe alors à l’état Vrai.

2ème méthode de Kinderman – Monahan
J’ai ajouté cet algorithme car il est 30% plus rapide en VBA que le précédent et me permet de générer plus de 3 millions de nombres gaussiens par seconde.

Public Function NormalRandomKM(Optional ByVal Esperance As Double = 0, _
Optional ByVal EcartType As Double = 1, _
Optional ByVal ForceRandomize As Boolean = False) As Double
'Générateur de nombres pseudo-aléatoires à distribution normale : Ratio method (Kinderman - Monahan)
'Implementation en VBA par Philben - v1.0 - Free to use
Const c As Double = 1.71552776992141 + 3.59296E-15 'sqrt(8/e)
Static isRandomize As Boolean
Dim u As Double, v As Double, x As Double

If Not isRandomize Or ForceRandomize Then
Randomize
isRandomize = True
End If

Do
v = Rnd()
Do: u = Rnd(): Loop While u = 0
x = (v - 0.5) * c / u
Loop Until (x * x < -4 * Log(u))

NormalRandomKM = Esperance + (x * EcartType)
End Function

Les paramètres de la fonction sont identiques à la précédente.

Limite des générateurs
Notre couple Randomize/Rnd n’est pas une source parfaitement aléatoire de nombres entre 0 et 1[, on ne peut donc espérer un miracle concernant les nombres gaussiens générés… Dans l’état, ces fonctions ne peuvent pas être utilisées pour un usage ‘scientifique’.
Dans ce cas, il faudrait utiliser un meilleur générateur de nombres aléatoires type Mersenne Twister ou autres (voir billet précédent) et vérifier que la distribution est qualitativement correcte.

Visualiser la distribution normale
La fonction suivante génère un visuel de la distribution normale centrée réduite des nombres aléatoires dans la fenêtre ‘Exécution’ de l’éditeur Visual Basic :

Public Function VisuelNormalRandom()
'Visuel de la distribution des nombres aléatoires gaussiens - v1.1
Const cNbClasse As Long = 16, cNbEcartType As Double = 4, cRangeClasse As Double = cNbEcartType / cNbClasse
Dim i As Long, aCompte(-cNbClasse To cNbClasse) As Long, NumClasse As Long, lMax As Long
Dim r As Double

For i = 1 To 50000
r = NormalRandomKM() / cRangeClasse
NumClasse = Int(Abs(r))
If Abs(r) > NumClasse + 0.5 Then NumClasse = NumClasse + 1

If NumClasse <= cNbClasse Then
NumClasse = NumClasse * Sgn(r)
aCompte(NumClasse) = aCompte(NumClasse) + 1
If aCompte(NumClasse) > lMax Then lMax = aCompte(NumClasse)
End If
Next i

'Affiche la distribution
Debug.Print "Distribution des nombres aléatoires" & vbCrLf & "-----------------------------------"
For i = LBound(aCompte) To UBound(aCompte)
r = i * cRangeClasse
Debug.Print IIf(Sgn(r) >= 0, " ", "") & Format(r, "0.0#"), String(CDbl(aCompte(i)) / lMax * 50 + 1, "=")
Next i
End Function

Coller l’ensemble des fonctions dans un module standard. Si la fenêtre d’exécution n’est pas visible, appuyer sur Ctrl+G puis mettre le focus dans la fonction précédente et appuyer sur F5 pour l’exécuter.

Vous devriez obtenir à peu près ceci :

Théoriquement, 68% des nombres générés sont dans l’intervalle + ou – 1 écart-type autour de la moyenne, 95% entre 2 écarts-types et 99,7% entre 3 écarts-types.

Pour aller plus loin sur le sujet, cette publication récente passe en revue de nombreuses méthodes et algorithmes.

Philippe

Extraire les séries de valeurs

philben — Tue, 08 May 2012 16:52:44 +0000

Un forumeur souhaitait connaître les séries de valeurs pour chaque famille et chaque donnee.
Une requête permet de répondre à la question…

Création de la table et insertion des données

Public Function CreationFamille()
Const cTable As String = "tFamilles"
With DoCmd
.SetWarnings False

.RunSQL "CREATE TABLE " & cTable & _
" (Famille LONG, Donnee VARCHAR(15), Valeur INTEGER," & _
" CONSTRAINT PrimaryKey PRIMARY KEY (Famille, Donnee, Valeur));"

.SetWarnings True
End With

InsertionFamilles
End Function

Public Sub InsertionFamilles()
Const cNombreFamille As Integer = 1
Const cTable As String = "tFamilles"
Const cInsert As String = "INSERT INTO " & cTable & " VALUES "
Dim i As Integer

With DoCmd
.SetWarnings False

i = Nz(DMax("famille", cTable)) + 1
For i = i To i + cNombreFamille - 1
.RunSQL cInsert & "(" & i & ", 'div', 1302);", False
.RunSQL cInsert & "(" & i & ", 'div', 1303);", False
.RunSQL cInsert & "(" & i & ", 'div', 1308);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1290);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1292);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1293);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1294);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1295);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1296);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1297);", False
Next i

.SetWarnings True
End With
MsgBox "Création terminée"
End Sub

Résultat attendu

famille donnee mini maxi
1 div 1302 1303
1 div 1308 1308
1 dov 1290 1290
1 dov 1292 1297

Le groupe composé de la famille 1 et de la donnee ‘div’ possède 2 séries de valeurs dont la première est composée de 2 nombres qui se suivent (1302 à 1303) et la seconde n’est composée que d’un seul nombre (1308).

La requête SQL

SELECT T.famille,
T.donnee,
MIN(T.mini) AS mini,
T.maxi AS maxi

FROM (SELECT t1.famille,
t1.donnee,
t1.valeur AS mini,
MAX(t2.valeur) AS maxi
FROM tFamilles AS T1
INNER JOIN tFamilles AS T2
ON (t1.valeur <= t2.valeur)
AND
(t1.famille = t2.famille)
AND
(t1.donnee = t2.donnee)
WHERE (SELECT COUNT(*)
FROM tfamilles T
WHERE t.famille = t1.famille
AND
t.donnee = t1.donnee
AND
t.valeur BETWEEN t1.valeur AND t2.valeur
) = (t2.valeur - T1.valeur + 1 )
GROUP BY t1.famille,
t1.donnee,
t1.valeur
) AS T
GROUP BY T.famille,
T.donnee,
T.maxi
ORDER BY T.famille,
T.donnee,
MIN(T.mini);

Explications
On part d’une auto jointure interne sur la table (…FROM tFamilles T1 INNER JOIN tFamilles T2…) qui nous permettra de confronter chaque valeur de tFamilles aux autres (un peu comme deux boucles For/Next imbriquées).
Les contraintes de jointure (…ON t1.valeur<=t2.valeur AND t1.famille=t2.famille AND t1.donnee=t2.donnee…) limitent les valeurs de T2 testées pour chaque valeur de T1 puisque l’on souhaite connaître les séries par famille et donnee. De plus, on impose que les valeurs de T1 soient inférieures ou égales à celles de T2 pour faciliter la suite…

La clause WHERE contient une sous-requête (…SELECT COUNT(*)…) qui compte le nombre de lignes de la table tFamille entre T1.Valeur et T2.Valeur pour la famille et la donnee courante (…t.famille=t1.famille and t.donnee=t1.donnee…). Le nombre de lignes issues de cette sous-requête est comparé au nombre de lignes attendues entre T1.Valeur et T2.Valeur (Exemple : 1302 – 1300 + 1 = 3 valeurs [1300,1301,1302]) pour que la série entre ces deux valeurs soit complète.
Si les deux nombres sont égaux, la série est complète et on la conserve.

A ce niveau là, on se retrouve avec toutes les séries intermédiaires entre le minimum et la maximum de chaque série complète entre t1.Valeur et T2.Valeur.
Exemple : Pour la série complète 1300 à 1302 on obtient aussi les séries intermédiaires 1300 à 1300, 1300 à 1301, 1300 à 1302, 1301 à 1301, 1301 à 1302 et 1302 à 1302.

Il reste donc à trouver le minimum et la maximum de chaque série.
Pour ce faire, on regroupe les données par famille, donnee et T1.Valeur (la valeur basse de chaque série) puis par la fonction d’agrégation MAX(T2.Valeur) on retient la valeur maximale des séries qui commencent par T1.valeur. Dans notre exemple, on réduit donc les séries à : 1300 à 1302, 1301 à 1302 et 1302 à 1302.

Pour déterminer la valeur minimale des séries, on procède sur le même principe en regroupant par famille, donnee et maxi (valeur haute de chaque série que l’on vient de déterminer). La fonction d’agrégation MIN(T1.Valeur) donnera le minimum de chaque série, soit 1300 dans notre exemple.

Performance
Les 3 colonnes appartiennent à la clef primaire ce qui permet à Access d’utiliser un index qui optimise la requête.

Si vous souhaitez augmenter le nombre de lignes de la table, il suffit de modifier la valeur de la constante ‘cNombreFamille’ (100 par exemple) de la fonction InsertionFamilles() et de la relancer. Eviter d’insérer trop de lignes à la fois car RunSQL n’est pas très rapide…

Philippe

Plages de trous entre les séries de valeurs

philben — Thu, 10 May 2012 19:04:15 +0000

Faisant suite au billet précédent, on aurait pu vouloir les plages de trous entre les séries de valeurs pour chaque famille et donnee.
Une requête permet d’y répondre…

Création de la table et insertion des données

Public Function CreationFamille()
Const cTable As String = "tFamilles"
With DoCmd
.SetWarnings False

.RunSQL "CREATE TABLE " & cTable & _
" (Famille LONG, Donnee VARCHAR(15), Valeur INTEGER," & _
" CONSTRAINT PrimaryKey PRIMARY KEY (Famille, Donnee, Valeur));"

.SetWarnings True
End With

InsertionFamilles
End Function

Public Sub InsertionFamilles()
Const cNombreFamille As Integer = 1
Const cTable As String = "tFamilles"
Const cInsert As String = "INSERT INTO " & cTable & " VALUES "
Dim i As Integer

With DoCmd
.SetWarnings False

i = Nz(DMax("famille", cTable)) + 1
For i = i To i + cNombreFamille - 1
.RunSQL cInsert & "(" & i & ", 'div', 1302);", False
.RunSQL cInsert & "(" & i & ", 'div', 1303);", False
.RunSQL cInsert & "(" & i & ", 'div', 1308);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1290);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1292);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1293);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1294);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1295);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1296);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1297);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1300);", False
.RunSQL cInsert & "(" & i & ", 'dov', 1301);", False
Next i

.SetWarnings True
End With
MsgBox "Création terminée"
End Sub

Résultat attendu

famille donnee Mini Maxi
1 div 1304 1307
1 dov 1291 1291
1 dov 1298 1299

La requête SQL

Explications
Le principe de base (auto jointure interne) est le même que pour le billet précédent.
Par la clause WHERE suivante ‘t1.valeur < T2.valeur – 1′, on ne retient que les combinaisons de valeurs distantes (1 et 3 par exemple et non 1 et 2) puis la sous-requête compte le nombre de valeurs entre ces deux limites incluses. Si le compte est exactement égal à 2 on a donc un trou (gap pour les anglophones et autres…) dans la série.
La plage de trous est comprise entre la valeur mini + 1 et la valeur maxi – 1.

Si l’on souhaite aussi inclure les plages de trous externes aux valeurs de la table, une solution consiste à utiliser une requête UNION entre les deux limites choisies.
Par exemple, pour retourner toutes les plages de trous entre 1 et 2000 :

SELECT t1.famille,
t1.donnee,
t1.valeur + 1 AS Mini,
t2.valeur - 1 AS Maxi
FROM tFamilles AS T1
INNER JOIN tFamilles AS T2
ON ( t1.donnee = t2.donnee )
AND ( t1.famille = t2.famille )
WHERE t1.valeur < T2.valeur - 1
AND (
SELECT COUNT(*)
FROM tfamilles T
WHERE t.famille = t1.famille
AND t.donnee = t1.donnee
AND t.valeur BETWEEN t1.valeur AND t2.valeur
) = 2
UNION
SELECT famille,
donnee,
1 AS Mini,
MIN(valeur) - 1 AS Maxi
FROM tFamilles
GROUP BY famille,
donnee
HAVING MIN(valeur) > 1
UNION
SELECT famille,
donnee,
MAX(valeur) + 1 AS Mini,
2000 AS Maxi
FROM tFamilles
GROUP BY famille,
donnee
HAVING MAX(valeur) < 2000;

Philippe

Indexer un tri de tableau

philben — Tue, 20 Mar 2012 20:40:41 +0000

Dans certaines circonstances, il est nécessaire de ne pas trier le tableau originel mais d’indexer le tri dans un tableau secondaire.
Voici la fonction de tri indexé avec Shellsort…

'ShellsortIndex - Philben - v1.0 - 03/2012
'Utilisable pour des tailles de tableau jusqu'à 10 000 000
'Les valeurs des gaps au-dessus de 1750 sont extrapolées et ne sont certainement pas les plus efficaces !
'Si le type de tableau est Integer, modifier :
' - ByRef a() As Long en ByRef a() As Integer
' - Dim ref As Long en Dim ref As Integer
Public Function ShellSortIndex(ByRef a() As Long, ByRef Idx() As Long, ByVal lowerBound As Long, ByVal upperBound As Long)
Dim ref As Long
Dim h As Long, i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, refIdx As Long, g As Variant

ReDim Idx(lowerBound To upperBound)
For i = lowerBound To upperBound: Idx(i) = i: Next i

g = Array(1, 4, 10, 23, 57, 132, 301, 701, 1750, 4376, 10941, 27353, 68383, 170958, 427396, 1068491, 2671228)
n = upperBound - lowerBound + 1

l = LBound(g)
If n < g(UBound(g)) Then
k = l
While g(k + 1) < n: k = k + 1: Wend
Else
k = UBound(g)
End If

While k >= l
h = g(k)
m = lowerBound + h
For i = m To upperBound
ref = a(Idx(i))
refIdx = Idx(i)
j = i
Do While ref < a(Idx(j - h)) '< pour un tri croissant, sinon >
Idx(j) = Idx(j - h)
j = j - h
If j < m Then Exit Do
Loop
Idx(j) = refIdx
Next i
k = k - 1
Wend
End Function

Le tableau Idx() contient l’ordre des valeurs du tableau a().
Par exemple, Les valeurs triées sont obtenues par :

For i = LBound(Idx) To UBound(Idx)
Debug.Print a(Idx(i))
Next i

Remarque
Le tri par index est moins rapide que le tri du tableau lui-même. Compter 40 à 50% de temps en plus.

Fonction performante de tri de tableaux

philben — Mon, 19 Mar 2012 22:08:37 +0000

Il existe plusieurs dizaines de méthodes de tri de tableaux et la plus renommée est Quicksort en terme de rapidité.
Qu’en est-il en VBA ?

J’ai testé plusieurs algorithmes dont Insertionsort, Heapsort, Mergesort, Quicksort, mais mon préféré reste Shellsort par sa compacité, simplicité et sa rapidité. L’efficacité de Shellsort réside dans le choix des gaps qui ont fait l’objet de multiples publications depuis les années 60. Les meilleurs gaps semblent bien définis jusqu’à la valeur de 1750.

Ma fonction Shellsort

'Shellsort - Philben - v1.0 - 03/2012
'Utilisable pour des tailles de tableau jusqu'à 10 000 000
'La valeur des gaps au-dessus de 1750 sont extrapolées et ne sont certainement pas les plus efficaces !
'Si le type de tableau est Integer, modifier :
' - ByRef a() As Long en ByRef a() As Integer
' - Dim ref As Long en Dim ref As Integer
Public Function ShellSort(ByRef a() As Long, ByVal lowerBound As Long, ByVal upperBound As Long)
Dim ref As Long
Dim h As Long, i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, g As Variant

g = Array(1, 4, 10, 23, 57, 132, 301, 701, 1750, 4376, 10941, 27353, 68383, 170958, 427396, 1068491, 2671228)
n = upperBound - lowerBound + 1

l = LBound(g)
If n < g(UBound(g)) Then
k = l
While g(k + 1) < n: k = k + 1: Wend
Else
k = UBound(g)
End If

While k >= l
h = g(k)
m = lowerBound + h
For i = m To upperBound
ref = a(i)
j = i
Do While ref < a(j - h) '< pour un tri croissant, sinon >
a(j) = a(j - h)
j = j - h
If j < m Then Exit Do
Loop
a(j) = ref
Next i
k = k - 1
Wend
End Function

Le face à face
Après avoir trouvé sur le web une bonne implémentation de Qsort (Quicksort non récursif), j’ai comparé leur rapidité à trier différentes tailles de tableau.
Les résultats de Shellsort en prenant comme base 100 les résultats de Qsort pour le tri d’entiers long :

Analyse des résultats
Shellsort est plus rapide (jusqu’à 30% plus rapide !) que Qsort pour des tableaux inférieurs à 100 000 valeurs. Au-delà, Qsort creuse petit à petit l’écart.
Compter une dizaine de millisecondes pour trier un tableau de 10 000 valeurs, 160ms pour 100 000 et 2 secondes pour 1 million de valeurs.

Conclusion
En VBA et pour des tableaux jusqu’à 100 000 valeurs, Shellsort est un algorithme de tri très rapide. Si vous possédez une fonction encore plus rapide, merci de l’ajouter en commentaire.