1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
|
'Degrés de liberté maximum pour ProbFisher (permet une précision d'au moins 4 chiffres sur p)
Private Const gclMaxDF As Long = 16384
' Type retourné par la fonction RegLinDom [Calcul de la droite de régression y = f(x)]
Public Type tRegLin
bErreur As Boolean ' Vrai en cas d'erreur
sMsgErreur As String ' Message d'erreur
dPente As Double ' Valeur de la pente de la droite de régression
dStDevPente As Double ' Ecart-type de la pente
dOrdonnee As Double ' Ordonnée à l'origine de la droite
dStDevOrigine As Double ' Ecart-type de l'origine
dErreurTypeY As Double ' Erreur-type des y estimés par la droite
fr2 As Single ' Coefficient de détermination (r x r)
lCompte As Long ' Nombre de couples (x,y) ou enregistrements utilisés
lCompteX As Long ' Nombre de valeurs uniques de x
vMinX As Variant ' Valeur minimum de x
vMaxX As Variant ' Valeur maximum de x
fProbaFisherLinearite As Single ' Probabilité du test de linéarité
fProbaStudentPente As Single ' Probabilité du test de liaison
End Type
'************************************************************************************************
'* Fonction : RegLinDom [Calcul de la droite de régression linéaire de y en x (y = ax + b)]
'* Auteur : PhilBen (© dans le cas d'un usage professionnel)
'* Version : 1.0
'* Publication : 22/07/2006 (www.developpez.com)
'* Dépendances : RegLinDom |-> IsStatDomErr -> StatExpressionErr
'* |-> ProbStudent -> ProbFisher
'* |-> ProbFisher
'* Rappel : La régression porte sur la variation d'une quantité y en fonction d'une
'* quantité x. Elle exprime la liaison entre un facteur x contrôlé
'* (valeurs connues a priori) et une variable aléatoire y liée (ne pas confondre
'* avec la corrélation qui étudie la liaison entre 2 variables totalement
'* aléatoires).
'* Objectifs : - Déterminer la forme de la liaison linéaire y = ax + b, en calculant par
'* la méthode des moindres carrés, la pente (a) et l'ordonnée à l'origine (b)
'* de la droite de régression ajustée au plus près aux données observées;
'* - Tester la linéarité de la courbe de régression et l'existence d'une liaison
'* significative entre la cause (x) et l'effet (y).
'* Paramètres : - sExpressionX : Identifiant obligatoire de la variable X qui peut être le
'* nom d'un champ numérique ou une expression calculée issus
'* du domaine étudié;
'* - sExpressionY : Identifiant obligatoire de la variable Y qui peut être le
'* nom d'un champ numérique ou une expression calculée issus
'* du domaine étudié;
'* - sDomaine : Identifiant obligatoire du nom de la table ou de la requête
'* qui porte les enregistrements du domaine étudié;
'* - sCritere : Expression facultative permettant de restreindre l'étendue
'* du domaine étudié (équivalent à l'argument de la clause WHERE
'* d'une requête SQL)
'* - bMsgBoxErr : Valeur boléenne facultative (Vrai par défaut) indiquant
'* si la fonction affiche ou non un message en cas d'erreur
'* Type retourné: Contenu du type tRegLin :
'* - bErreur : Valeur (type boolean) à Vrai si une erreur est survenue
'* - sMsgErreur : Chaîne de caractère décrivant l'éventuelle erreur rencontrée
'* - dPente : Valeur (type Double) de la pente de la droite de régression
'* - dStDevPente : Valeur (type Double) de l'écart-type de la pente
'* - dOrdonnee : Valeur (type Double) de l'ordonnée à l'origine de la droite
'* - dStDevOrigine: Valeur (type Double) de l'écart-type de l'ordonnée
'* - dErreurTypeY : Valeur (type Double) de l'erreur-type associée aux y estimés
'* par la droite de régression. Permet de calculer les intervalles
'* de prévision et de confiance des y autour de la droite
'* - fr2 : Valeur (type Single) du coefficient de détermination (r au carré)
'* Peut varier dans l'intervalle [0 à 1]. Plus sa valeur est grande
'* plus la droite de régression explique la variabilité des y
'* - lCompte : Valeur (type Long) du nombre de couples (x,y) ou enregistrements
'* utilisés pour le calcul de la droite de régression
'* - lCompteX : Valeur (type Long) du nombre de valeurs uniques de x utilisées
'* - vMinX : Valeur (type Variant) minimum des x
'* - vMaxX : Valeur (type Variant) maximum des x
'* - fProbaFisherLinearite As Double : Valeur (type Single) de la probabilité (p)
'* [0 à 1], de l'hypothèse nulle de linéarité. La probabilité est
'* calculée d'après la loi F de Fisher-Snedecor et nous indique
'* si l'écart des y le long de la droite peut être expliqué par
'* l'écart dû aux fluctuations d'échantillonnage des y entre eux.
'* Si p > 0,05 l'hypothèse de linéarité est admissible (à 5 %)
'* Si p <= 0,05 la linéarité est rejetée au risque 5 %
'* - fProbaStudentPente : Valeur (type Single) de la probabilité [0 à 1], calculée
'* d'après la loi t de Student-Fisher, que la la pente ne diffère
'* pas de zéro, en d'autres termes que la variable y est indépendante
'* de x. Si la probabilité du test est <= au risque de 1ère espèce
'* alpha consenti (en général 5 %), on dira que la pente diffère
'* significativement de 0 au seuil 5 % et l'hypothèse d'indépendance
'* est rejetée.
'* En résumé, si p > 0,05 la liaison n'est pas significative (à 5%)
'* et si p <= 0,05 la liaison est significative et p mesure son
'* degré de signification.
'* Rem. : Ce type de test peut être utilisé pour comparer 2 pentes
'* Remarques : A) On considère que la droite de régression représente convenablement la courbe
'* de régression de y en x si :
'* - l'hypothèse de linéarité est admise (p > 0,05)
'* - l'hypothèse d'indépendance (non liaison) est rejetée (p <= 0,05)
'* B) Une droite de régression statistiquement linéaire ne prétend représenter
'* la variation de y en fonction de x que sur l'intervalle étudié [xMin à xMax].
'* Exemple : Dim tRL as tRegLin
'* tRL = RegLinDom("MonChampX", "MonChampY", "MaTable")
'* If Not tRL.bErreur then
'* ' Si la courbe de régression des données est bien estimée par notre droite
'* ' et si la liaison x <-> y est significative, c'est tout bon !
'* If dProbaFisherLinearite > 0.05 And dProbaStudentPente <= 0.05 then
'* ...utilisation de la droite
'* endif
'* endif
'************************************************************************************************
Public Function RegLinDom(ByVal sExpressionX As String, ByVal sExpressionY As String, _
ByVal sDomaine As String, Optional ByVal sCritere As String = vbNullString, _
Optional ByVal bMsgBoxErr As Boolean = True) As tRegLin
On Error GoTo RLErr
Dim oDb As DAO.Database
Dim oRs As DAO.Recordset
Dim dSommeX As Double, dSommeCarreX As Double, dSommeY As Double, dSommeCarreY As Double
Dim dSommeXY As Double, dDeltaX As Double, dDeltaY As Double, dDeltaXY As Double
Dim dSommeCarreYSurX As Double, dVarDevDroite As Double, dVarIntraY As Double
Dim dEcartEntreY As Double
Dim sSql As String, sTmp As String
If Not IsStatDomErr(RegLinDom.sMsgErreur, "RegLin", sDomaine, sExpressionX, sExpressionY) Then
sTmp = "(" & sExpressionX & ") Is Not Null AND (" & sExpressionY & ") Is Not Null"
sCritere = IIf(Len(Trim$(sCritere)) > 0, sCritere & " AND " & sTmp, sTmp)
sTmp = "((" & sExpressionX & ") * (" & sExpressionY & "))"
sSql = "SELECT Sum(" & sExpressionX & ") AS SommeX, " & _
"Sum(" & sExpressionY & ") AS SommeY, " & _
"Sum(" & sTmp & ") AS SommeXY, " & _
"Sum((" & sExpressionX & ") ^ 2) AS SommeCarreX, " & _
"Sum((" & sExpressionY & ") ^ 2) AS SommeCarreY, " & _
"Min(" & sExpressionX & ") AS MinX, " & _
"Max(" & sExpressionX & ") AS MaxX, " & _
"Count(*) AS Compte " & _
"FROM " & sDomaine & " WHERE " & sCritere & ";"
Set oDb = CurrentDb
Set oRs = oDb.OpenRecordset(sSql, dbOpenForwardOnly)
If Not oRs.EOF Then
RegLinDom.lCompte = oRs.Fields("Compte")
RegLinDom.vMinX = oRs.Fields("MinX")
RegLinDom.vMaxX = oRs.Fields("MaxX")
dSommeX = oRs.Fields("SommeX")
dSommeY = oRs.Fields("SommeY")
dSommeXY = oRs.Fields("SommeXY")
dSommeCarreX = oRs.Fields("SommeCarreX")
dSommeCarreY = oRs.Fields("SommeCarreY")
dDeltaX = RegLinDom.lCompte * dSommeCarreX - dSommeX ^ 2
dDeltaY = RegLinDom.lCompte * dSommeCarreY - dSommeY ^ 2
dDeltaXY = RegLinDom.lCompte * dSommeXY - dSommeX * dSommeY
If RegLinDom.lCompte > 2 And dDeltaX > 0 And dDeltaY > 0 Then
RegLinDom.dPente = dDeltaXY / dDeltaX
RegLinDom.dOrdonnee = (dSommeCarreX * dSommeY - dSommeX * dSommeXY) / dDeltaX
RegLinDom.dStDevPente = ((dDeltaY / dDeltaX - RegLinDom.dPente ^ 2) / (RegLinDom.lCompte - 2)) ^ 0.5
RegLinDom.dStDevOrigine = RegLinDom.dStDevPente * (dSommeCarreX / RegLinDom.lCompte) ^ 0.5
RegLinDom.dErreurTypeY = ((dDeltaY - dDeltaXY ^ 2 / dDeltaX) / (RegLinDom.lCompte * (RegLinDom.lCompte - 2))) ^ 0.5
RegLinDom.fr2 = dDeltaXY ^ 2 / (dDeltaX * dDeltaY)
RegLinDom.fProbaStudentPente = ProbStudent(RegLinDom.dPente / RegLinDom.dStDevPente, RegLinDom.lCompte - 2)
sSql = "SELECT Count(*) AS CompteUniqueX, " & _
"Count(" & sExpressionX & ") AS CompteX, " & _
"Sum(" & sExpressionY & ") AS SommeY, " & _
"[SommeY] ^ 2 / [CompteX] AS SommeCarreYSurX " & _
"FROM " & sDomaine & " WHERE " & sCritere & " GROUP BY " & sExpressionX & ";"
Set oRs = oDb.OpenRecordset(sSql, dbOpenForwardOnly)
If Not oRs.EOF Then
RegLinDom.lCompteX = oRs.Fields("CompteUniqueX")
Do Until oRs.EOF
dSommeCarreYSurX = dSommeCarreYSurX + oRs.Fields("SommeCarreYSurX")
oRs.MoveNext
Loop
If RegLinDom.lCompteX > 2 And RegLinDom.lCompte > RegLinDom.lCompteX Then
dEcartEntreY = dSommeCarreYSurX - (dSommeY ^ 2 / RegLinDom.lCompte)
dVarDevDroite = (dEcartEntreY - (RegLinDom.dPente ^ 2 * dDeltaX / RegLinDom.lCompte)) / _
(RegLinDom.lCompteX - 2) 'd.d.l. = Nb Colonnes - 1 - 1(pour la Régression)
dVarIntraY = (dSommeCarreY - dSommeCarreYSurX) / _
(RegLinDom.lCompte - 1 - (RegLinDom.lCompteX - 1))
RegLinDom.fProbaFisherLinearite = ProbFisher(dVarDevDroite / dVarIntraY, _
RegLinDom.lCompteX - 2, RegLinDom.lCompte - RegLinDom.lCompteX)
Else
RegLinDom.bErreur = True
RegLinDom.sMsgErreur = "Test de linéarité non réalisable..." & vbCrLf
If RegLinDom.lCompteX <= 2 Then
RegLinDom.sMsgErreur = RegLinDom.sMsgErreur & _
"Le nombre de valeurs uniques de la variable x doit être > à 2."
Else
RegLinDom.sMsgErreur = RegLinDom.sMsgErreur & _
"Le nombre de couples de valeurs (x,y) doit être > au nombre de valeurs uniques de x."
End If
End If
Else
RegLinDom.bErreur = True
RegLinDom.sMsgErreur = "Test de linéarité non réalisé..." & vbCrLf & _
"Aucun enregistrement retourné par le domaine."
End If
Else
RegLinDom.bErreur = True
RegLinDom.sMsgErreur = "Droite de régression non calculable..." & vbCrLf
If RegLinDom.lCompte <= 2 Then
RegLinDom.sMsgErreur = RegLinDom.sMsgErreur & _
"Le nombre de couples de valeurs (x,y) doit être > à 2."
Else
RegLinDom.sMsgErreur = RegLinDom.sMsgErreur & "La variance des x et des y doivent être > à zéro."
End If
End If
Else
RegLinDom.bErreur = True
RegLinDom.sMsgErreur = "Droite de régression non calculée..." & vbCrLf & _
"Aucun enregistrement retourné par le domaine."
End If
End If
fin:
Set oRs = Nothing
Set oDb = Nothing
If bMsgBoxErr And RegLinDom.bErreur Then
MsgBox RegLinDom.sMsgErreur
End If
Exit Function
RLErr:
RegLinDom.bErreur = True
RegLinDom.sMsgErreur = "Erreur n°" & Err.Number & vbCrLf & "Description :" & Err.Description
Resume fin
End Function
' Vérifie sommairement les paramètres de la fonction de statistiques
Private Function IsStatDomErr(sMsgErr As String, sNomFunc As String, _
sDomaine As String, sExpression1 As String, _
Optional sExpression2 As String = vbNullString) As Boolean
sMsgErr = vbNullString
If Len(Trim$(sDomaine)) = 0 Then
sMsgErr = "<Domaine> ne peut être vide..."
Else
sMsgErr = StatExpressionErr(sNomFunc, Trim$(sExpression1))
If Len(sMsgErr) = 0 And sExpression2 <> vbNullString Then
sMsgErr = StatExpressionErr(sNomFunc, Trim$(sExpression2))
End If
End If
If Len(sMsgErr) > 0 Then IsStatDomErr = True
End Function
' Vérifie sommairement les expressions
Private Function StatExpressionErr(sNomFunc As String, sExpression As String) As String
If Len(sExpression) = 0 Then
StatExpressionErr = "<Expression> ne peut être vide..."
ElseIf sExpression = "*" Or InStr(1, sExpression, ".*", vbBinaryCompare) > 0 Then
StatExpressionErr = "Le " & sNomFunc & " ne peut être calculé sur l'ensemble des colonnes (*)..."
ElseIf InStr(1, sExpression, ",", vbBinaryCompare) > 0 Then
StatExpressionErr = "<Expression> ne doit pas retourner plus d'un champ..."
ElseIf InStr(1, sExpression, " AS ", vbTextCompare) > 0 Then
StatExpressionErr = "Le champ de <Expression> ne doit pas être aliasé..."
End If
End Function
' ProbFisher renvoie la probabilité suivant la loi F de Fisher
' Permet de calculer indirectement la probabilité de la loi t, normale et Khi2
' Remarque : - Code légèrement modifié par moi (PB) pour éviter une erreur de calcul (voir source)
Public Function ProbFisher(ByVal dFRatio As Double, _
ByVal lDF1 As Long, _
ByVal lDF2 As Long) As Single
' From : Egon Dorrer, "Algorithm 322: F-Distribution [S14]", Communications of the
' Association for Computing Machinery 11:2:116-117 (1968).
On Error GoTo errortag
Const cdEpsilon As Double = 0.000001
Dim dInvPi As Double
Dim w As Double, y As Double, z As Double, zk As Double, d As Double, p As Double
Dim i As Long, j As Long
Dim a As Integer, b As Integer
If dFRatio < cdEpsilon Or lDF1 < 1 Or lDF2 < 1 Then
ProbFisher = 1
GoTo fin
End If
If lDF1 > gclMaxDF Then lDF1 = gclMaxDF 'clMaxDF ~ infini
If lDF2 > gclMaxDF Then lDF2 = gclMaxDF
dInvPi = 1 / (4 * Atn(1)) ' 1 / Pi
a = IIf(lDF1 Mod 2 = 0, 2, 1)
b = IIf(lDF2 Mod 2 = 0, 2, 1)
w = dFRatio * lDF1 / lDF2
z = 1 / (1 + w)
If a = 1 Then
If b = 1 Then
p = w ^ 0.5
d = dInvPi * z / p
p = 2 * dInvPi * Atn(p)
Else
p = (w * z) ^ 0.5
d = 0.5 * p * z / w
End If
ElseIf b = 1 Then
p = z ^ 0.5
d = 0.5 * p * z
p = 1 - p
Else
d = z * z
p = w * z
End If
y = 2 * w / z
If a = 1 Then
For i = b + 2 To lDF2 Step 2
d = d * (1 + a / (i - 2)) * z
p = p + (d * y / (i - 1))
Next i
Else
'zk = z ^ ((lDF2 - 2) / 2) ' Code original mais zk faux si b = 2
' -> Code modifié par PB :
If b = 2 Then
zk = z ^ ((lDF2 - 2) / 2)
Else
zk = z ^ ((lDF2 - 1) / 2)
End If
' <- Fin du code modifié
d = d * zk * lDF2 / b
p = p * zk + w * z * (zk - 1) / (z - 1)
End If
y = w * z
z = 2 / z
b = lDF2 - 2
For i = a + 2 To lDF1 Step 2
j = i + b
d = d * y * j / (i - 2)
p = p - (z * d / j)
Next i
If p < 0 Then
p = 0
ElseIf p > 1 Then
p = 1
End If
ProbFisher = 1 - p
fin:
Exit Function
errortag:
ProbFisher = -1
Resume fin
End Function
' ProbStudent renvoie la probabilité suivant la loi t de Student (bilatéral)
Public Function ProbStudent(t As Double, lDF As Long) As Single
ProbStudent = ProbFisher(t ^ 2, 1, lDF)
End Function
' ProbNormal renvoie la probabilité suivant la loi normale centrée réduite (bilatéral)
Public Function ProbNormal(dEcart As Double) As Single
ProbNormal = ProbFisher(dEcart ^ 2, 1, gclMaxDF)
End Function
' ProbKhi2 renvoie la probabilité du Khi2
Public Function ProbKhi2(dKhi2 As Double, lDF As Long) As Single
ProbKhi2 = IIf(lDF > 0, ProbFisher(dKhi2 / lDF, lDF, gclMaxDF), -1)
End Function |
22/07/2006, 20h49
Régression linéaire, loi F, t, normale et Khi-2
00
