Datenauswertung, Polynomanpassung mit graphischer Darstellung

Beispielprogramm zur Eingabe und Auswertung von Meßwertreihen, Anpassung mit Polynomfunktion der Grade 1 bis 6. Gedacht als Fundgrube für etwas Fortgeschrittene. Das Programm bietet folgende Optionen : Sinnvolle Erweiterungen zur Übung wären:

'Deklarationsteil
Option Explicit
Dim Xv(100) As Single, Yv(100) As Single, Paar%, Funktyp%, xg!(2), yg!(2), init As Boolean
Dim Nachkomma%, xminmerk!, xmaxmerk!, yminmerk!, ymaxmerk!
'Voreinstellungen im Arbeitsfenster:
Private Sub Form_Load()
Paar = 0
Picture2.Picture = Image1(0).Picture
Funktyp = 1
Combo1.ListIndex = 1
Nachkomma = 1
init = True'unerwünschte Reaktion beim Stellen vehindern
HScroll1(0).Value = 10'vgl. dazu die Scroll_Change-Routinen!
HScroll1(1).Value = 10
VScroll1(0).Value = 10
VScroll1(1).Value = 10
init = False
xg(1) = -10
xg(2) = 10
yg(1) = -10
yg(2) = 10
Label3.Caption = xg(1)
Label4.Caption = xg(2)
Label5.Caption = yg(2)
Label6.Caption = yg(1)
End Sub
'Malen ist in "Form_Load" nicht möglich, Achsenkreuz soll beim Start erscheinen:
Private Sub Form_Activate()
Achsenkreuz
End Sub
'Auswertung der Mausstellung über dem Diagramm, Picture1
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
x = Int(x * 10 ^ Nachkomma + 0.5) / 10 ^ Nachkomma
y = Int(y * 10 ^ Nachkomma + 0.5) / 10 ^ Nachkomma
Label1.Caption = "x = " & x
Label2.Caption = "y = " & y
End Sub
'wenn Maus Picture1 verläßt, Koordinatenanzeige löschen:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Label1.Caption = "x = "
Label2.Caption = "y = "
End Sub
'Erzeugen und Löschen von Meßpunkten durch Mausklick:
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i%, j%
Select Case Button
Case 1'Punkt rein
x = Int(x * 10 ^ Nachkomma + 0.5) / 10 ^ Nachkomma
y = Int(y * 10 ^ Nachkomma + 0.5) / 10 ^ Nachkomma
Picture1.DrawWidth = 4
Picture1.PSet (x, y), Picture1.ForeColor
Paar = Paar + 1
Xv(Paar) = x
Yv(Paar) = y
Sortiere Paar, Xv(), Yv()
If Paar > 2 Then Option1(1).Enabled = True'autom. Achsenwahl
Case 2>'Punkt raus
For i = 1 To Paar
If x * Xv(i) >= 0 And y * Yv(i) >= 0 Then
If Abs(x) > 0.95 * Abs(Xv(i)) And Abs(x) < 1.05 * Abs(Xv(i)) And _
Abs(y) > 0.95 * Abs(Yv(i)) And Abs(y) < 1.05 * Abs(Yv(i)) Then
Picture1.DrawWidth = 5
Picture1.PSet (Xv(i), Yv(i)), Picture1.BackColor
For j = i To Paar - 1
Xv(j) = Xv(j + 1)
Yv(j) = Yv(j + 1)
Next
Paar = Paar - 1
End If
End If
Next
End Select
End Sub
'Hilfskomponenten einstellen und auswerten
Private Sub Combo1_Click()'Nachkommastellen
Nachkomma = Combo1.ListIndex
End Sub
Private Sub Command3_Click()'Ende-Befehl
End
End Sub
Private Sub Option1_Click(Index As Integer)'Art des Achsenkreuzes
Dim xmin!, xmax!, ymin!, ymax!, i%
Select Case Index
Case 0'Achsenkreuz nach Wahl
xg(1) = xminmerk
xg(2) = xmaxmerk
yg(1) = yminmerk
yg(2) = ymaxmerk
Frame1.Visible = True
Case 1'Achsenkreuz automatisch
xminmerk = xg(1)'vorhandene Einstellung merken
xmaxmerk = xg(2)
yminmerk = yg(1)
ymaxmerk = yg(2)
Frame1.Visible = False'Einstellkreuz verbergen
xmin = 1000'Suche der neuen Grenzen
xmax = -1000
ymin = 1000
ymax = -1000
For i = 1 To Paar
If Xv(i) < xmin Then xmin = Xv(i)
If Xv(i) > xmax Then xmax = Xv(i)
If Yv(i) < ymin Then ymin = Yv(i)
If Yv(i) > ymax Then ymax = Yv(i)
Next
xg(1) = xmin - 0.05 * (xmax - xmin)
xg(2) = xmax + 0.05 * (xmax - xmin)
yg(1) = ymin - 0.05 * (ymax - ymin)
yg(2) = ymax + 0.05 * (ymax - ymin)
End Select
Achsenkreuz
End Sub
Private Sub Option2_Click(Index As Integer)'Auswertungsformel wählen und anzeigen, Bilder mit den Formeltexten
If Option2(Index).Value Then Picture2.Picture = Image1(Index).Picture
Funktyp = Index + 1
End Sub
Private Sub HScroll1_Change(Index As Integer)'x-Achsenbegrenzung
xg(1) = -HScroll1(0).Value: Label3.Caption = xg(1)
xg(2) = HScroll1(1).Value: Label4.Caption = xg(2)
If Not init Then Achsenkreuz
End Sub
Private Sub VScroll1_Change(Index As Integer)'y-Achsenbegrenzung
yg(2) = VScroll1(0).Value: Label5.Caption = yg(2)
yg(1) = -VScroll1(1).Value: Label6.Caption = yg(1)
If Not init Then Achsenkreuz
End Sub
Private Sub Command1_Click()'Berechnung und Anzeige
Dim Gld As Integer
Dim i As Integer, j As Integer, k As Integer
Dim Fak As Single
Dim Mat(25, 25) As Single
Dim Lös(25) As Single
Dim Rech As Single, dx As Single, y As Single
Dim xa!, ya!
Dim Std As Single, Vari As Single
If Paar < Funktyp + 1 Then
MsgBox "Zahl der Wertepaare nicht ausreichend!"
Exit Sub
End If
Gld = Funktyp + 1
For i = 1 To Gld
For j = 1 To Gld + 1
Mat(i, j) = 0
Next
Next
Mat(1, 1) = Paar'Werteeingabe + Aufbau der Matrix
For i = 1 To Paar
Mat(1, Gld + 1) = Mat(1, Gld + 1) + Yv(i)
Fak = 1
For j = 2 To Gld
Fak = Fak * Xv(i)
Mat(1, j) = Mat(1, j) + Fak
Mat(j, Gld + 1) = Mat(j, Gld + 1) + Fak * Yv(i)
Next
For j = 2 To Gld
Fak = Fak * Xv(i)
Mat(j, Gld) = Mat(j, Gld) + Fak
Next
Next
For i = 2 To Gld
For j = 1 To Gld - 1
Mat(i, j) = Mat(i - 1, j + 1)
Next
Next
For k = 1 To Gld - 1'lineares Gleichungssystem
For i = k + 1 To Gld
If Mat(k, k) < 1E-30 Then Mat(k, k) = 1E-30
Rech = Mat(i, k) / Mat(k, k)
Mat(i, k) = 0
For j = k + 1 To Gld + 1
Mat(i, j) = Mat(i, j) - Rech * Mat(k, j)
Next
Next
Next
If Mat(Gld, Gld) < 1E-30 Then Mat(Gld, Gld) = 1E-30
Lös(Gld) = Mat(Gld, Gld + 1) / Mat(Gld, Gld)
For i = Gld - 1 To 1 Step -1
Rech = Mat(i, Gld + 1)
For j = i + 1 To Gld
Rech = Rech - Mat(i, j) * Lös(j)
Next
Lös(i) = Rech / Mat(i, i)
Next
Picture1.DrawWidth = 1'Ergebniskurve
dx = (xg(2) - xg(1)) / 100
y = 0
For i = 0 To Funktyp
y = y + Lös(i + 1) * (xg(1)) ^ i
Next
Picture1.PSet (xg(1), y)
xa = xg(1)
ya = y
For j = 1 To 100
y = 0
For i = 0 To Funktyp
y = y + Lös(i + 1) * (xg(1) + j * dx) ^ i
Next
If y > 2 * yg(1) And y < 2 * yg(2) Then'Fehldarstellung durch Werte weit
Picture1.Line (xa, ya)-(xg(1) + j * dx, y)'außerhalb des Picture-Bereiches
End If'vermeiden
xa = xg(1) + j * dx
ya = y
Next
Label8.Caption = ""'Koeffizientenausgabe
For i = 0 To Funktyp
Label8.Caption = Label8.Caption & Chr$(97 + i) & " = " & Format$(Lös(Funktyp + 1 - i), "0.000")
If i < Funktyp Then Label8.Caption = Label8.Caption & "; "
Next
Label8.Caption = Label8.Caption & ". "
Std = 0'Standardabweichung
For i = 1 To Paar
Vari = 0
For j = Funktyp To 0 Step -1
Vari = Vari + Lös(j + 1) * Xv(i) ^ j
Next
Std = Std + (Vari - Yv(i)) ^ 2
Next
Std = Sqr(Std / (Paar - Funktyp))
Label8.Caption = Label8.Caption & "Sigma = " & Format$(Std, "0.000")
End Sub
Private Sub Command2_Click()'Bild und Daten löschen
Picture1.Cls
Paar = 0
Label8.Caption = ""
Option1(1).Enabled = False
Achsenkreuz
End Sub
'eigenständige Sub-Routinen
Private Sub Achsenkreuz()'Achsenkreuz, ggf. Meßpunkte malen
Dim i%, Strw!, Strs!
Picture1.Cls
Picture1.DrawWidth = 1
Picture1.Scale (xg(1), yg(2))-(xg(2), yg(1))
Picture1.Line (xg(1), 0)-(xg(2), 0)
Picture1.Line (0, yg(1))-(0, yg(2))
Strw = (xg(2) - xg(1)) / 100
Strs = (yg(2) - yg(1)) / 100
For i = xg(1) To xg(2)
Picture1.Line (i, 0)-(i, -Strs)
Next
For i = yg(1) To yg(2)
Picture1.Line (0, i)-(Strw, i)
Next
If Paar <> 0 Then
Picture1.DrawWidth = 5
For i = 1 To Paar
Picture1.PSet (Xv(i), Yv(i))
Next
End If
End Sub

Zur folgenden Sortierroutine: Wer wesentlich mehr als nur so ein paar lumpige Werte sortieren will, kann zu einer aufwendigeren und schnelleren Sortierroutine greifen. Naserümpfen über das langsame Bubblesort ist zwar sehr verbreitet, aber brauche ich einen Porsche, um beim Bäcker nebenan die Brötchen zu holen?

Sub Sortiere(Zahl%, X!(), Y!())'Bubble-Sort aufsteigend
Dim i%, fertig As Boolean
Dim Hilf1!, Hilf2!
Do
fertig = True
For i = 1 To Zahl - 1
If X(i) > X(i + 1) Then
fertig = False
Hilf1 = X(i)
Hilf2 = Y(i)
X(i) = X(i + 1)
Y(i) = Y(i + 1)
X(i + 1) = Hilf1
Y(i + 1) = Hilf2
End If
Next>
Loop Until fertig
End Sub
zum Anfang
© R. Hirte * 2004