MS-Office-Forum
Google
   

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads Der Renner, 11 Entwicklertools für Access, Tipps & Trick und offene Datenbanken zum einzigartigen Preis.
Themen-Optionen Ansicht
Alt 13.07.2011, 12:56   #16
ClaudeG
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Danke für die neue Version und auch die Version von K-means mit der zweiten Tabellenblatt!

Aber wenn man nun ohne Diagram arbeiten möchte, kann man dann nicht einfach die Farbe der verschiedenen Punkte in der Tabelle entsprechen ihrer Zugehörigkeit der Gruppe anmalen?
ClaudeG ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.07.2011, 10:11   #17
ransi
MOF Koryphäe
MOF Koryphäe
Standard

HAllo Claude

Für den K-Means:
 AB
1x-Wertey-Werte
2657738
3163818
4251202
5279198
6181444
7706709
852447
9254234
10683611
11695776
12721759
13713588
14937410
15113570
16690295
17270911
18485718
19835972
20292574
21683434
22133613
23123686
24905961
25347467
26457877
27133752
28922777
29801897
30292494
3141129


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4


Färben kannst du dann einfach so:
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub CommandButton1_Click()
Call machs
End Sub


Public Sub machs()
'http://de.wikipedia.org/wiki/K-Means-Algorithmus
Dim arr As Variant

Dim S As Double, T As Integer, Iterationen As Integer
Dim tmp As Double
Dim L As Long, I As Integer, K As Integer

'#########
Dim Bereich As Range
Set Bereich = Sheets("Tabelle1").Range("A2:B2000")
Bereich.Interior.ColorIndex = xlNone 'Entfärben
arr = Bereich 'Wertebereich
'#########

Dim startPunkte(1 To 3) '"eine vorher bekannte Anzahl von k Gruppen gebildet. "
'#####
With Sheets("Tabelle2")
    '#####
    For Iterationen = 1 To 5
        Stop 'Schau dir das Diagramm und die Startwerte an! Weiter mit F5
        startPunkte(1) = .Range("C22") 'Startpunkte festlegen
        startPunkte(2) = .Range("E2:F2")
        startPunkte(3) = .Range("G2:H2")
        .Range("C3:H2000").ClearContents 'Aufräumen
        
        For L = 1 To UBound(arr)
            tmp = 100000000
            T = 0
            For I = 1 To 3
                S = get_Distance(arr(L, 1), startPunkte(I)(1, 1), arr(L, 2), startPunkte(I)(1, 2))
                If S < tmp Then
                    tmp = S
                    T = I
                End If
            Next I
            Select Case T '"Jedes Objekt wird demjenigen Cluster zugeordnet, dessen Schwerpunkt ihm am nächsten liegt. "
                Case 1
                    .Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = arr(L, 1)
                    .Range("D" & Rows.Count).End(xlUp).Offset(1, 0) = arr(L, 2)
                    '##############
                    Bereich.Rows(L).Interior.Color = RGB(0, 0, 255) 'Blau
                    '##############
                Case 2
                    .Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = arr(L, 1)
                    .Range("F" & Rows.Count).End(xlUp).Offset(1, 0) = arr(L, 2)
                    '##############
                    Bereich.Rows(L).Interior.Color = RGB(0, 255, 0) 'Grün
                    '##############
                Case 3
                    .Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = arr(L, 1)
                    .Range("H" & Rows.Count).End(xlUp).Offset(1, 0) = arr(L, 2)
                    '##############
                    Bereich.Rows(L).Interior.Color = RGB(255, 0, 0) 'Rot
                    '##############
            End Select
        Next L
        '"Für jeden Cluster wird der Schwerpunkt neu berechnet, sodass dieser in der Mitte des Clusters liegt.
        .Range("C2").Value = CDbl(WorksheetFunction.Average(.Range(.Range("C3"), .Range("C3").End(xlDown)))) 'Mittelwerte der x-Werte startpunkte(1)
        .Range("D2").Value = CDbl(WorksheetFunction.Average(.Range(.Range("D3"), .Range("D3").End(xlDown)))) 'Mittelwerte der y-Werte startpunkte(1)
        .Range("E2").Value = CDbl(WorksheetFunction.Average(.Range(.Range("E3"), .Range("E3").End(xlDown)))) 'Mittelwerte der x-Werte startpunkte(2)
        .Range("F2").Value = CDbl(WorksheetFunction.Average(.Range(.Range("F3"), .Range("F3").End(xlDown)))) 'Mittelwerte der y-Werte startpunkte(1)
        .Range("G2").Value = CDbl(WorksheetFunction.Average(.Range(.Range("G3"), .Range("G3").End(xlDown)))) 'Mittelwerte der x-Werte startpunkte(3)
        .Range("H2").Value = CDbl(WorksheetFunction.Average(.Range(.Range("H3"), .Range("H3").End(xlDown)))) 'Mittelwerte der y-Werte startpunkte(3)
    Next Iterationen
End With
MsgBox "Habe fertig"
End Sub

Public Function get_Distance(x1, x2, y1, y2)
'"Dazu muss eine Distanzfunktion, ..., verwendet werden."
'A² + B² = C²
get_Distance = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
End Function


Für DBSCAN muss ich mal schauen wie das am besten geht...

ransi
ransi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.07.2011, 10:39   #18
ClaudeG
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Danke für K-Means hat super funktioniert bei mir sogar mit 8 Variablen und 6 Startpunkte!

Aber wie gesagt bei DBScan gibt es das Problem dass es die Gruppen nicht anzeigt!

Auf jedenfall vielen Dank für deine Hilfe
ClaudeG ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.07.2011, 10:54   #19
ClaudeG
Threadstarter Threadstarter
Neuer Benutzer
Neuer Benutzer
Standard

Hallo,

Hab noch eine Frage gibt es auch die Möglichkeit dass man die Tabelle(Daten) danach nach den Farben ordnet damit dann alle mit der gleichen Farbe hintereinander kommen? Vielleicht sogar die Tabelle kopieren und geordnet nach den Farben auf ein neues Tabellenblatt schreiben?
ClaudeG ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 03.01.2018, 17:27   #20
jcridge
Neuer Benutzer
Neuer Benutzer
Standard

I provid an edited version of ransi's DBSCAN_v2 code, see below.
Believe the v2 code had an error in the location of the second clause "If L <> K Then" etc
Reader can find my edits by searching for XXX etc.

A nice and simple test data set to explore the error seems to be :

UserX UserY
2 8
3 8
4 8
2 7
3 7
4 7
2 6
3 6
4 6
2 5
3 5
4 5


Public Sub machs()
Dim arr As Variant
Dim S As Long
Dim T As Double
Dim L As Long
Dim K As Long
Dim Z As Long
Dim isRP As Boolean
Dim isNoise As Boolean
Dim CP
Dim NP As Long
Dim RP As Long
Dim gN
Dim R

'mindestens 4 Nachbarn
'at least 4 neighbors
'Const MinPts = 10
'Const MinDistance = 1

Dim MinPts As Integer
Dim MinDistance As Double

MinPts = XXX ' Cells(55, 19)
MinDistance = XXX ' Cells(56, 19)

arr = Range("A2:B1000")

ReDim CorePoints(1 To UBound(arr), 1 To 2)
ReDim Noise(1 To UBound(arr), 1 To 2)
ReDim arrTmp(1 To UBound(arr), 1 To 2)
ReDim EdgePoints(1 To UBound(arr), 1 To 2)
ReDim Rest(1 To UBound(arr), 1 To 2)

'alles was keinen Nacharn hat kommt in Noise(), die anderen ist Rest()
'Anything that has no neighbors comes in Noise (), the rest is ()
For L = 1 To UBound(arr)
isNoise = True
For K = 1 To UBound(arr)
T = get_Distance(arr(L, 1), arr(K, 1), arr(L, 2), arr(K, 2))
If T <= MinDistance Then
If L <> K Then
isNoise = False
Exit For
End If
End If
Next
If isNoise Then
NP = NP + 1
Noise(NP, 1) = arr(L, 1)
Noise(NP, 2) = arr(L, 2)
Else:
R = R + 1
Rest(R, 1) = arr(L, 1)
Rest(R, 2) = arr(L, 2)
End If
Next
'Schleife über den Rest um CorePoints zu finden
'Ein Corepoint hat mindestens MinPts NAchbarn in höchstens MinDistance-Entfernung

'Loop over the rest to find CorePoints
'A corepoint has at least MinPts next to MinDistance distance
For L = 1 To R
S = 0
' If L <> K Then ' JR edit out XXX
For K = 1 To R
T = get_Distance(Rest(L, 1), Rest(K, 1), Rest(L, 2), Rest(K, 2))
If T <= MinDistance Then
If L <> K Then ' JR edit in XXX
S = S + 1
If S >= MinPts Then
Exit For
End If
End If ' JR edit in XXX
End If
Next
If S < MinPts Then
RP = RP + 1
arrTmp(RP, 1) = Rest(L, 1)
arrTmp(RP, 2) = Rest(L, 2)
Else:
CP = CP + 1
CorePoints(CP, 1) = Rest(L, 1)
CorePoints(CP, 2) = Rest(L, 2)
End If
' End If ' JR edit out XXX
Next
'arrTmp enthält EdgePoints und Noise
'arrTmp contains boundary points and noise
'#################


'alles in arrTMP was einen CorePoint als Nachbarn hat ist ein Randpunkt.
'Alles andere ist Noise()
'everything in arrTMP that has a CorePoint as a neighbor is an edge point.
'Everything Else is Noise ()
For L = 1 To RP
For K = 1 To CP
isNoise = True
T = get_Distance(arrTmp(L, 1), CorePoints(K, 1), arrTmp(L, 2), CorePoints(K, 2))
If T <= MinDistance Then
isNoise = False
Exit For
End If
Next K
If isNoise Then
NP = NP + 1
Noise(NP, 1) = arrTmp(L, 1)
Noise(NP, 2) = arrTmp(L, 2)
Else:
gN = gN + 1
EdgePoints(gN, 1) = arrTmp(L, 1)
EdgePoints(gN, 2) = arrTmp(L, 2)
End If
Next L

'update XLS worksheet
Range("D2:I3000").ClearContents

Range("D1") = "core points"
Range("D2:E" & CP + 1) = CorePoints

Range("F1") = "edge points"
If Not IsEmpty(gN) Then
Range("F2:G" & gN + 1) = EdgePoints
End If
Range("H1") = "noise points"
If Not IsEmpty(NP) And NP > 0 Then
Range("H2:I" & NP + 1) = Noise
End If
End Sub



Public Function get_Distance(x1, x2, y1, y2)
'"Dazu muss eine Distanzfunktion, ..., verwendet werden."
'"For this a distance function, ..., must be used."
'A² + B² = C²
get_Distance = Sqr((x1 - x2) ^ 2 + (y1 - y2) ^ 2)
End Function
jcridge ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 10.01.2018, 14:39   #21
jcridge
Neuer Benutzer
Neuer Benutzer
Standard DBSCAN_v2 - > DBSCAN_v3

Bitte finden Sie eine überarbeitete Version von Ransis ausgezeichnetem DBSCAN_v2 13.07.2011, 13:24.

Ich habe auch einige neue synthetische Testdaten aufgenommen.

Steuerparameter sind jetzt auf dem HMI usw.

Schlage den Nutzern vor, zuerst das einfache Rechteck der Punkte "test1" zu analysieren
Angehängte Dateien
Dateityp: xlsm DBSCAN_v3.xlsm (40,6 KB, 0x aufgerufen)
jcridge ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 09:43 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

Copyright ©2000-2010 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günther Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.
Beachten Sie bitte auch unsere Nutzungsbedingungen.