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 |
Partager