PDA

Vollständige Version anzeigen : Mathematische Funktionen: Statistik und Trigonometrie


FW
23.09.2006, 14:31
... weil hier und da immer mal wieder danach gefragt wird und es hier im Forum keine solche Zusammenfassungen gibt, hier einige grundlegende statistische und trigonometrische Funktionen:

Statistische Funktionen:
' Filtert aus einem varianten Datenfeld die numerischen Werte und liefert diese zurück. Ggf. werden 0-Werte ignoriert

Public Function ZahlenFilter(ByVal varArr As Variant, Optional ByVal bolIgnoreZero As Boolean = False) As Variant
Dim lngLB As Long, lngUB As Long, lngCnt As Long, lngVar As Long
Dim dblVals() As Double

lngLB = LBound(varArr)
lngUB = UBound(varArr)
For lngVar = lngLB To lngUB
If IsNumeric(varArr(lngVar)) Then
If Not bolIgnoreZero Or CDbl(varArr(lngVar)) <> 0 Then
ReDim Preserve dblVals(0 To lngCnt)
dblVals(lngCnt) = CDbl(varArr(lngVar))
lngCnt = lngCnt + 1
End If
End If
Next lngVar
ZahlenFilter = dblVals
End Function

'Statistische Funktionen

Public Function Anzahl(ParamArray varVals() As Variant) As Long
Anzahl = UBound(ZahlenFilter(varVals)) + 1
End Function

Public Function GeometrischesMittel(ParamArray varVals() As Variant) As Variant
Dim lngUB As Long, lngVar As Long
Dim dblGeo As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
dblGeo = 1
For lngVar = 0 To lngUB
If varArr(lngVar) < 0 Then
GeometrischesMittel = Null
Exit Function
End If
dblGeo = dblGeo * varArr(lngVar)
Next lngVar
GeometrischesMittel = dblGeo ^ (1 / (lngUB + 1))
End Function

Public Function Haeufigkeit(ByVal dblVal As Double, ParamArray varVals() As Variant) As Long
Dim lngUB As Long, lngVar As Long, lngCnt As Long
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 1 To lngUB
If varArr(lngVar) = dblVal Then lngCnt = lngCnt + 1
Next lngVar
Haeufigkeit = lngCnt
End Function

Public Function Maximum(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblMax As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
dblMax = varArr(0)
For lngVar = 1 To lngUB
If varArr(lngVar) > dblMax Then dblMax = varArr(lngVar)
Next lngVar
Maximum = dblMax
End Function

Public Function Median(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar1 As Long, lngVar2 As Long
Dim dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar1 = 0 To lngUB - 1
For lngVar2 = lngVar1 + 1 To lngUB
If varArr(lngVar1) > varArr(lngVar2) Then
dblVar = varArr(lngVar1)
varArr(lngVar1) = varArr(lngVar2)
varArr(lngVar2) = dblVar
End If
Next lngVar2
Next lngVar1
If lngUB Mod 2 Then
Median = (varArr((lngUB - 1) \ 2) + varArr((lngUB - 1) \ 2 + 1)) / 2
Else
Median = varArr(lngUB \ 2)
End If
End Function

Public Function Minimum(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblMin As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
dblMin = varArr(0)
For lngVar = 1 To lngUB
If varArr(lngVar) < dblMin Then dblMin = varArr(lngVar)
Next lngVar
Minimum = dblMin
End Function

Public Function MittelAbweichung(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblAvg As Double, dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblAvg = dblAvg + varArr(lngVar)
Next lngVar
dblAvg = dblAvg / (lngUB + 1)
For lngVar = 0 To lngUB
dblVar = dblVar + Abs(varArr(lngVar) - dblAvg)
Next lngVar
MittelAbweichung = dblVar / (lngUB + 1)
End Function

Public Function Mittelwert(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblAvg As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblAvg = dblAvg + varArr(lngVar)
Next lngVar
Mittelwert = dblAvg / (lngUB + 1)
End Function

Public Function Modalwert(ParamArray varVals() As Variant) As Variant
Dim lngUB As Long, lngVar1 As Long, lngVar2 As Long, lngCnts() As Long
Dim dblMdl As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
ReDim lngCnts(0 To lngUB)
For lngVar1 = 0 To lngUB - 1
For lngVar2 = lngVar1 + 1 To lngUB
If varArr(lngVar1) = varArr(lngVar2) Then lngCnts(lngVar1) = lngCnts(lngVar1) + 1
Next lngVar2
Next lngVar1
lngVar1 = 0
For lngVar2 = 1 To lngUB
If lngCnts(lngVar1) < lngCnts(lngVar2) Then lngVar1 = lngVar2
Next lngVar2
For lngVar2 = 0 To lngUB
If lngVar2 <> lngVar1 And lngCnts(lngVar2) = lngCnts(lngVar1) Then
Mdl = Null
Exit Function
End If
Next lngVar2
Modalwert = varArr(lngVar1)
End Function

Public Function Produkt(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
dblkVar = 1
For lngVar = 0 To lngUB
dblVar = dblVar * varArr(lngVar)
Next lngVar
Produkt = dblVar
End Function

Public Function QuadratMittel(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblVar = dblVar + varArr(lngVar) ^ 2
Next lngVar
QuadratMittel = Sqr(dblVar / (lngUB + 1))
End Function

Public Function Random(ParamArray varVals() As Variant) As Double
Dim varArr As Variant

Randomize
varArr = ZahlenFilter(varVals)
Random = varArr(Fix((UBound(varArr) + 1) * Rnd))
End Function

Public Function Rang(ByVal dblVal As Double, ByVal bolAsc As Boolean, ParamArray varVals() As Variant) As Long
Dim lngUB As Long, lngVar1 As Long, lngVar2 As Long
Dim dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar1 = 0 To lngUB - 1
For lngVar2 = lngVar1 + 1 To lngUB
If IIf(bolAsc, varArr(lngVar1) > varArr(lngVar2), varArr(lngVar1) < varArr(lngVar2)) Then
dblVar = varArr(lngVar1)
varArr(lngVar1) = varArr(lngVar2)
varArr(lngVar2) = dblVar
End If
Next lngVar2
Next lngVar1
For lngVar1 = 0 To lngUB
If varArr(lngVar1) = dblVal Then
Rang = lngVar1 + 1
Exit Function
End If
Next lngVar1
End Function

Public Function Spannweite(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblMax As Double, dblMin As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
dblMax = varArr(0)
dblMin = varArr(0)
For lngVar = 1 To lngUB
If varArr(lngVar) > dblMax Then dblMax = varArr(lngVar)
If varArr(lngVar) < dblMin Then dblMin = varArr(lngVar)
Next lngVar
Spannweite = dblMax - dblMin
End Function

Public Function Standardabweichung(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblAvg As Double, dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblAvg = dblAvg + varArr(lngVar)
Next lngVar
dblAvg = dblAvg / (lngUB + 1)
For lngVar = 0 To lngUB
dblVar = dblVar + (varArr(lngVar) - dblAvg) ^ 2
Next lngVar
Standardabweichung = Sqr(dblVar / (lngUB + 1))
End Function

Public Function Summe(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblVar = dblVar + varArr(lngVar)
Next lngVar
Summe = dblVar
End Function

Public Function Varianz(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblAvg As Double, dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblAvg = dblAvg + varArr(lngVar)
Next lngVar
dblAvg = dblAvg / (lngUB + 1)
For lngVar = 0 To lngUB
dblVar = dblVar + (varArr(lngVar) - dblAvg) ^ 2
Next lngVar
Varianz = dblVar / (lngUB + 1)
End Function
Trigonometrische Funktionen:
Public Const cstPi As Double = 3.14159265389793
Public Const cstE As Double = 2.71828182845905

' Grad -> Radiant

Public Function DegToRad(ByVal dblDeg)
DegToRad = cstPi * dblDeg / 180
End Function

' Radiant -> Grad

Public Function RadToDeg(ByVal dblRad)
RadToDeg = 180 * dblRad / cstPi
End Function

' ArcusSinus

Public Function Acs(ByVal dblX As Double)
If dblX = 0 Then
Acs = cstPi / 2
Else
Acs = Atn(Sqr(1 - dblX * dblX) / dblX)
End If
End Function

' ArcusCotangens

Public Function Act(ByVal dblX As Double)
If dblX = 0 Then
Act = cstPi / 2
Else
Act = Atn(1 / dblX)
End If
End Function

' AreaCosinusHyperbolicus

Public Function ArCosh(ByVal dblX As Double)
ArCosh = Log(dblX + Sqr(dblX * dblX - 1))
End Function

' AreaCotangensHyperbolicus

Public Function ArCoth(ByVal dblX As Double)
ArCoth = 0.5 * Log((1 - dblX) / (1 + dblX))
End Function

' AreaSinusHyperbolicus

Public Function ArSinh(ByVal dblX As Double)
ArSinh = Log(dblX + Sqr(dblX * dblX + 1))
End Function

' AreaTangensHyperbolicus

Public Function ArTanh(ByVal dblX As Double)
ArTanh = 0.5 * Log((1 + dblX) / (1 - dblX))
End Function

' ArcusSinus

Public Function Asn(ByVal dblX As Double)
If Abs(dblX) = 1 Then
Asn = Sgn(dblX) * cstPi / 2
Else
Asn = Atn(dblX / Sqr(1 - dblX * dblX))
End If
End Function

' Cosinus: Cos()

' CosinusHyperbolicus

Public Function Cosh(ByVal dblX As Double)
Cosh = (cstE ^ dblX + cstE ^ -dblX) / 2
End Function

' Cotangens

Public Function Cot(ByVal dblRad As Double)
Cot = 1 / Tan(dblRad)
End Function

' CotangensHyperbolicus

Public Function Coth(ByVal dblX As Double)
Coth = Cosh(dblX) / Sinh(dblX)
End Function

' Sinus: Sin()

' SinusHyperbolicus

Public Function Sinh(ByVal dblX As Double)
Sinh = (cstE ^ dblX - cstE ^ -dblX) / 2
End Function

' Tangens: Tan()

' TangensHyperbolicus

Public Function Tanh(ByVal dblX As Double)
Tanh = Sinh(dblX) / Cosh(dblX)
End Function

FW
19.10.2006, 00:45
... in dem obigen Code haben sich einige Fehler eingeschlichen:
Public Function Modalwert(ParamArray varVals() As Variant) As Variant
Dim lngUB As Long, lngVar1 As Long, lngVar2 As Long, lngCnts() As Long
Dim dblMdl As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
ReDim lngCnts(0 To lngUB)
For lngVar1 = 0 To lngUB - 1
For lngVar2 = lngVar1 + 1 To lngUB
If varArr(lngVar1) = varArr(lngVar2) Then lngCnts(lngVar1) = lngCnts(lngVar1) + 1
Next lngVar2
Next lngVar1
lngVar1 = 0
For lngVar2 = 1 To lngUB
If lngCnts(lngVar1) < lngCnts(lngVar2) Then lngVar1 = lngVar2
Next lngVar2
For lngVar2 = 0 To lngUB
If lngVar2 <> lngVar1 And lngCnts(lngVar2) = lngCnts(lngVar1) Then
Modalwert = Null
Exit Function
End If
Next lngVar2
Modalwert = varArr(lngVar1)
End Function

Public Function Produkt(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
dblVar = 1
For lngVar = 0 To lngUB
dblVar = dblVar * varArr(lngVar)
Next lngVar
Produkt = dblVar
End Function

Public Function QuadratMittel(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblVar = dblVar + varArr(lngVar) ^ 2
Next lngVar
QuadratMittel = Sqr(dblVar / (lngUB + 1))
End Function

Public Function Summe(ParamArray varVals() As Variant) As Double
Dim lngUB As Long, lngVar As Long
Dim dblVar As Double
Dim varArr As Variant

varArr = ZahlenFilter(varVals)
lngUB = UBound(varArr)
For lngVar = 0 To lngUB
dblVar = dblVar + varArr(lngVar)
Next lngVar
Summe = dblVar
End Function
Sorry...

tobik_318
05.08.2008, 14:28
Ich bin dir Dankbar für diese Funktionen.

Wäre es auch möglich die Empirische Varianz (s2) zu indegrieren?
Das wäre echt super.

Gruß Tobi

FW
06.08.2008, 11:16
... die Funktion Varianz entspricht eigentlich der empirischen Varianz, mit dem Unterschied, dass durch n statt (n-1) geteilt wird. Ersetze als einfach die Zeile
Varianz = dblVar / (lngUB + 1)
mit
Varianz = dblVar / lngUB
...

danieljena
08.03.2014, 13:11
Der Beitrag ist zwar schon etwas älter, aber ich ahbe doch eine Frage:
Hast du die rechnerrische Richtigkeit der Funktionen überprüfen lassen (von einer Zweigperson)?

FW
17.03.2014, 11:56
Hallo danieljena,
nein, weder von einer Zweig, noch von einer Zweitperson.
Ich kann nicht ausschließen, dass der Code noch Fehler hat, aber im Großen und Ganzen sollte das schon ok sein.
Gibt es Probleme?