Forced ranking using Schultze method

spkvist

New member
Local time
Today, 10:10
Joined
Jan 28, 2022
Messages
4
Hi

I am trying to build an Access database, where I can force rank a number of choices using the Schultze method.

In the attached database I have created a table with respondents, who has ranked 5 choices. The ranking data can be found in the Data table.

Schultze method: en.wikipedia.org/wiki/Schulze_method

Using the above Schultze method, I have been able to come some part of the way. Currently I am stuck with Pairwise preferences (see query "PairwisePreferences").

My challenge is that I need to also take the next steps.

I believe that I first need to use the Floyd-Warshall algoritm to find the shorts paths in a directed weighted graph (which I believe is what I have in the query PairwisePreferences".

Link to Floyd-Warshall algoritm can be found here: en.wikipedia.org/wiki/Floyd%E2%80%93Warshall_algorithm

When I have figures this out, I need some way to calculate the final result, so that I have the final Schultze ranking of the options.

Can someone possibly help me take the final steps in the attached database?

Kind regards

Søren Peter
 

Attachments

Here is a solution to the Floyd_Warshal algorithm. See if this helps.

As mentioned the code uses several class modules to help reading from and writing to the database. This will not be efficient, but makes the I/O a lot easier.
 
Hi MajP,
Thanks for your quick response.
I am basically trying to recalculate the example here: en.wikipedia.org/wiki/Schulze_method

As I understand the sample databases you have uploaded, you are not exactly achieving what the Schultze method is trying to achieve. I believe you are adding up the distances between each node, while the Schultze method is looking for the shortest link between 2 nodes, although is has to go through another node (if this makes sense).

I am basically looking for the weakest link in the strongest/longest path from one node to any other node.

I have no idea on how to do this in Access (unfortunately).

Kind regards

Søren Petr



SchultzeWeakestLInk.PNG
 
you are not exactly achieving what the Schultze method is trying to achieve. I believe you are adding up the distances between each node, while the Schultze method is looking for the shortest link between 2 nodes, although is has to go through another node (if this makes sense)
Of course I am not achieving the Schulze method, because I am solving the shortest path problem using the real Floyd-Warshal algorithm. The FW finds the shortest path between each node and every other node. The Schultze method is a modification of the FW to find the widest path and not the shortest path. It traverses every path from one node to another and finds the path with the maximum of its minimum legs.
So path 10-20-40 has a length of 70 and a minimum of 10
Path 5-80-40 has a length of 125 and a minimum of 5
The strongest path (max of min) is 10-20-40

My point is that I provide a 95% solution with all the code to read and write from an Access datbase and traverse all of the paths, You simply need to modify the FW algorithm to return the "Widest Path" and not the shortest path. This is done by storing the Min edge for each path instead of the Min distance of the total path.
Code:
Private m_Edges As Edges
'Need an NxN of the vertices not just the real edges
'------------ Procedures ----------------------------------------------
Public Sub InitializeFloyd_Marshall(TheEdges As Edges)
  Dim I As Long
  Dim j As Long
  Dim startKeys() As Variant
  Dim endKeys() As Variant
  Set Me.Edges = TheEdges
  startKeys = Me.Edges.startKeys
 
  For I = 0 To UBound(startKeys)
    endKeys = Me.Edges.endKeys(CStr(startKeys(I)))
    For j = 0 To UBound(endKeys)
      Me.Edges.Item(CStr(startKeys(I)), CStr(endKeys(j))).ShortestPathDistance = Me.Edges.Item(CStr(startKeys(I)), CStr(endKeys(j))).EdgeDistance
     Next j
  Next I
  Me.Edges.Item(CStr(startKeys(0)), CStr(endKeys(0))).ShortestPathDistance = 0
      
End Sub
Public Property Get Edges() As Edges
  Set Edges = m_Edges
End Property

Public Property Set Edges(ByVal TheEdges As Edges)
  Set m_Edges = TheEdges
End Property


Public Sub SolveAllPaths()
  Dim colOut As Collection
  Dim Neighbors() As Variant
  Dim SpanningVertex As Vertex
  Dim VisitedVertex As Vertex
  Dim TempVertex As Vertex
  Dim I_Key As String
  Dim J_Key As String
  Dim K_key As String
  Dim I As Integer
  Dim j As Integer
  Dim k As Integer
  Dim The_keys() As Variant
  Dim distance_i_j As Double
  Dim distance_i_k As Double
  Dim distance_k_j As Double
  Dim newDistance As Double
  Dim n As Long
 
  n = Me.Edges.count
  The_keys = Me.Edges.startKeys
  For k = 0 To n - 1
    K_key = The_keys(k)
    For I = 0 To n - 1
       I_Key = The_keys(I)
       For j = 0 To n - 1
         J_Key = The_keys(j)
         distance_i_j = Me.Edges.Item(I_Key, J_Key).ShortestPathDistance
         distance_i_k = Me.Edges.Item(I_Key, K_key).ShortestPathDistance
         distance_k_j = Me.Edges.Item(K_key, J_Key).ShortestPathDistance
         If distance_i_k = Infinity Or distance_k_j = Infinity Then
             newDistance = Infinity
         Else
             newDistance = distance_i_k + distance_k_j
         End If
         If newDistance < distance_i_j Then
              'Debug.Print "i,j,k " & I_Key & " " & J_Key & " " & K_key & " dist " & newDistance
             Me.Edges.Item(I_Key, J_Key).ShortestPathDistance = newDistance
             Me.Edges.Item(I_Key, J_Key).NextVertexKey = K_key
         End If
       Next j
    Next I
  Next k
End Sub
Public Function GetPath(startKey As String, endkey As String) As String
  Dim path As String
  If startKey = endkey Then
    path = ""
  Else
    path = Trim(RecursePath(startKey, endkey))
  End If
  If path <> "" Then
   path = " " & path & " "
  Else
   path = " "
  End If
  If path = "No path" Then
    GetPath = path
  Else
    GetPath = "Path: " & startKey & path & endkey
  End If
End Function
Public Function GetShortestPathDistance(startKey As String, endkey As String) As Double
 If startKey = endkey Then
   GetShortestPathDistance = 0
 Else
   GetShortestPathDistance = Me.Edges.Item(startKey, endkey).ShortestPathDistance
 End If
End Function
Private Function RecursePath(startKey As String, endkey As String) As String
 'recursively reconstruct shortest path from i to j using A and Nxt
 Dim TmpStartKey As String
 If Me.Edges.Exists(startKey, endkey) Then
   If Me.Edges.Item(startKey, endkey).ShortestPathDistance = Infinity Then
     RecursePath = "No path"
   Else
      TmpStartKey = Me.Edges.Item(startKey, endkey).NextVertexKey
      If TmpStartKey = "" Then  'The path from i to j is shortest and exists
       RecursePath = ""
      Else
       'Debug.Print startKey & " " & TmpStartKey
       RecursePath = RecursePath(startKey, TmpStartKey) & " " & TmpStartKey & " " & RecursePath(TmpStartKey, endkey)
       RecursePath = Trim(RecursePath)
      End If
   End If
 Else
   RecursePath = "No path"
 End If
End Function
 
Last edited:
Hi MajP,
I am extremely grateful for your help.
I have used your Dijkstra8 as a starting point.
I have inserted my own edges (see below)

1643389539653.png



I have then made a new version of Dijstra8, where I have modified the FW code based on the exact above code, which you have provided.
For some reason I get the exact same result.
As output, I need the weakest link within the strongest path for all combinations of A-B, A-C, A-C, B-A, B-B, etc. etc.



Kind regards

Søren Peter
 
Hi MajP,
I am extremely grateful for your help.
I have used your Dijkstra8 as a starting point.
I have inserted my own edges (see below)

View attachment 97884


I have then made a new version of Dijstra8, where I have modified the FW code based on the exact above code, which you have provided.
For some reason I get the exact same result.
As output, I need the weakest link within the strongest path for all combinations of A-B, A-C, A-C, B-A, B-B, etc. etc.



Kind regards

Søren Peter
Just realized that it seems as if the code has not been modified. I am afraid that I do not know how to modify the FW code correctly. Would really appreciate your help with this. Also please let me know, if there is anything I can do for you.

Kind regards

Søren Peter
Hi MajP,
I am extremely grateful for your help.
I have used your Dijkstra8 as a starting point.
I have inserted my own edges (see below)

View attachment 97884


I have then made a new version of Dijstra8, where I have modified the FW code based on the exact above code, which you have provided.
For some reason I get the exact same result.
As output, I need the weakest link within the strongest path for all combinations of A-B, A-C, A-C, B-A, B-B, etc. etc.



Kind regards

Søren Pete
Of course I am not achieving the Schulze method, because I am solving the shortest path problem using the real Floyd-Warshal algorithm. The FW finds the shortest path between each node and every other node. The Schultze method is a modification of the FW to find the widest path and not the shortest path. It traverses every path from one node to another and finds the path with the maximum of its minimum legs.
So path 10-20-40 has a length of 70 and a minimum of 10
Path 5-80-40 has a length of 125 and a minimum of 5
The strongest path (max of min) is 10-20-40

My point is that I provide a 95% solution with all the code to read and write from an Access datbase and traverse all of the paths, You simply need to modify the FW algorithm to return the "Widest Path" and not the shortest path. This is done by storing the Min edge for each path instead of the Min distance of the total path.
Code:
Private m_Edges As Edges
'Need an NxN of the vertices not just the real edges
'------------ Procedures ----------------------------------------------
Public Sub InitializeFloyd_Marshall(TheEdges As Edges)
  Dim I As Long
  Dim j As Long
  Dim startKeys() As Variant
  Dim endKeys() As Variant
  Set Me.Edges = TheEdges
  startKeys = Me.Edges.startKeys

  For I = 0 To UBound(startKeys)
    endKeys = Me.Edges.endKeys(CStr(startKeys(I)))
    For j = 0 To UBound(endKeys)
      Me.Edges.Item(CStr(startKeys(I)), CStr(endKeys(j))).ShortestPathDistance = Me.Edges.Item(CStr(startKeys(I)), CStr(endKeys(j))).EdgeDistance
     Next j
  Next I
  Me.Edges.Item(CStr(startKeys(0)), CStr(endKeys(0))).ShortestPathDistance = 0
    
End Sub
Public Property Get Edges() As Edges
  Set Edges = m_Edges
End Property

Public Property Set Edges(ByVal TheEdges As Edges)
  Set m_Edges = TheEdges
End Property


Public Sub SolveAllPaths()
  Dim colOut As Collection
  Dim Neighbors() As Variant
  Dim SpanningVertex As Vertex
  Dim VisitedVertex As Vertex
  Dim TempVertex As Vertex
  Dim I_Key As String
  Dim J_Key As String
  Dim K_key As String
  Dim I As Integer
  Dim j As Integer
  Dim k As Integer
  Dim The_keys() As Variant
  Dim distance_i_j As Double
  Dim distance_i_k As Double
  Dim distance_k_j As Double
  Dim newDistance As Double
  Dim n As Long

  n = Me.Edges.count
  The_keys = Me.Edges.startKeys
  For k = 0 To n - 1
    K_key = The_keys(k)
    For I = 0 To n - 1
       I_Key = The_keys(I)
       For j = 0 To n - 1
         J_Key = The_keys(j)
         distance_i_j = Me.Edges.Item(I_Key, J_Key).ShortestPathDistance
         distance_i_k = Me.Edges.Item(I_Key, K_key).ShortestPathDistance
         distance_k_j = Me.Edges.Item(K_key, J_Key).ShortestPathDistance
         If distance_i_k = Infinity Or distance_k_j = Infinity Then
             newDistance = Infinity
         Else
             newDistance = distance_i_k + distance_k_j
         End If
         If newDistance < distance_i_j Then
              'Debug.Print "i,j,k " & I_Key & " " & J_Key & " " & K_key & " dist " & newDistance
             Me.Edges.Item(I_Key, J_Key).ShortestPathDistance = newDistance
             Me.Edges.Item(I_Key, J_Key).NextVertexKey = K_key
         End If
       Next j
    Next I
  Next k
End Sub
Public Function GetPath(startKey As String, endkey As String) As String
  Dim path As String
  If startKey = endkey Then
    path = ""
  Else
    path = Trim(RecursePath(startKey, endkey))
  End If
  If path <> "" Then
   path = " " & path & " "
  Else
   path = " "
  End If
  If path = "No path" Then
    GetPath = path
  Else
    GetPath = "Path: " & startKey & path & endkey
  End If
End Function
Public Function GetShortestPathDistance(startKey As String, endkey As String) As Double
If startKey = endkey Then
   GetShortestPathDistance = 0
Else
   GetShortestPathDistance = Me.Edges.Item(startKey, endkey).ShortestPathDistance
End If
End Function
Private Function RecursePath(startKey As String, endkey As String) As String
'recursively reconstruct shortest path from i to j using A and Nxt
Dim TmpStartKey As String
If Me.Edges.Exists(startKey, endkey) Then
   If Me.Edges.Item(startKey, endkey).ShortestPathDistance = Infinity Then
     RecursePath = "No path"
   Else
      TmpStartKey = Me.Edges.Item(startKey, endkey).NextVertexKey
      If TmpStartKey = "" Then  'The path from i to j is shortest and exists
       RecursePath = ""
      Else
       'Debug.Print startKey & " " & TmpStartKey
       RecursePath = RecursePath(startKey, TmpStartKey) & " " & TmpStartKey & " " & RecursePath(TmpStartKey, endkey)
       RecursePath = Trim(RecursePath)
      End If
   End If
Else
   RecursePath = "No path"
End If
End Function
 
if you will run the Dijkstra algorithm on your table (post#6),
it will show you Exactly the same result as what you have in
that table (no 3 or 4 way point, but only 2 point).
so you only sort it and get the weakest (shortest), which is "E"-->"A"
 
Here is a working solution with the minimum objects needed.
SchultzStart.jpg

Click the calculate button
Schultzend.jpg


I will leave it up to you to start the starting query/table. I have it designed that you need a cartesian to include each vertext with itself. AA, BB, CC, DD, EE. These are zeros.

Here is the code to load the Schultz solver and then save the strength values back to the starting table.

Code:
Private edgs As Edges
Private SO As SchultzOrder
Private Sub cmdSchultz_Click()
  Dim rs As DAO.Recordset
  Set edgs = New Edges
  Dim I As Long
  Dim j As Long
 
  'For FW need all reall edges and fake edges
  Set rs = CurrentDb.OpenRecordset("tblNodesSchultz")
  Do While Not rs.EOF
    edgs.AddEdge rs!StartVertex, rs!EndVertex, rs!EdgeWeight
    rs.MoveNext
  Loop
  rs.Close
  Set SO = New SchultzOrder
  SO.Initialize edgs
  SO.SetStrength
  'Me.txtOut = ""
 
  UpdateStrengths
  Me.SubFrmEdges.Form.OrderBy = "Strength DESC"
  Me.SubFrmEdges.Form.OrderByOn = True
  Me.SubFrmEdges.Requery
  Me.subFrmStrengthmatrix.Requery
End Sub
Public Sub UpdateStrengths()
 Dim I As Integer
 Dim j As Integer
 Dim TheStartKeys() As Variant
 Dim TheEndKeys() As Variant
 Dim TheStartKey As String
 Dim TheEndKey As String
 Dim strSql As String
 
 TheStartKeys = SO.Edges.startKeys
 'TheStartKeys = Me.Edges.startKeys.Keys
 For I = 0 To UBound(TheStartKeys)
    TheStartKey = TheStartKeys(I)
    TheEndKeys = SO.Edges.endKeys(TheStartKey)
    For j = 0 To UBound(TheEndKeys)
    TheEndKey = TheEndKeys(j)
      strSql = "Update tblNodesSchultz Set Strength = " & SO.Edges.Item(TheStartKey, TheEndKey).EdgeStrength & " Where StartVertex = '" & TheStartKey & "' AND EndVertex = '" & TheEndKey & "'"
     ' Debug.Print strSql
      CurrentDb.Execute strSql
   Next j
  'Debug.Print ToString
  Next I
End Sub

Here is the modified algorithm changing it from Floyd_warshall to Schultz ordering. Minor change

Code:
Public Sub SetStrength()
'  # Input: d[i,j], the number of voters who prefer candidate i to candidate j.
'  # Output: p[i,j], the strength of the strongest path from candidate i to candidate j.

'for i from 1 to C
'    for j from 1 to C
'        if i ? j then
'            if d[i,j] > d[j,i] then
'                p[i,j] := d[i,j]
'            Else
'                p i,j:=0

'for i from 1 to C
'    for j from 1 to C
'        if i <> j then
'            for k from 1 to C
'                if i <> k and j <> k then
'                    p[j,k] := max (p[j,k], min (p[j,i], p[i,k]))
 
 
  Dim I_Key As String
  Dim J_Key As String
  Dim K_key As String
  Dim I As Integer
  Dim j As Integer
  Dim k As Integer
  Dim The_keys() As Variant
  Dim p_j_i As Double
  Dim p_j_k As Double
  Dim p_i_k As Double
  Dim newStrengh As Double
  Dim n As Long
  Dim oldpjk As Double
 
  n = Me.Edges.count
  The_keys = Me.Edges.startKeys
 
  For I = 0 To n - 1
    I_Key = The_keys(I)
    
    For j = 0 To n - 1
       J_Key = The_keys(j)
       If J_Key <> I_Key Then
       For k = 0 To n - 1
         K_key = The_keys(k)
            If I_Key <> K_key And J_Key <> K_key Then
                p_j_i = Me.Edges.Item(J_Key, I_Key).EdgeStrength
                p_i_k = Me.Edges.Item(I_Key, K_key).EdgeStrength
                p_j_k = Me.Edges.Item(J_Key, K_key).EdgeStrength
                oldpjk = p_j_k
               ' Debug.Print I_Key & J_Key & K_key
               ' Debug.Print "pJK: (" & J_Key & K_key & ") " & p_j_k & " pJI: (" & J_Key & I_Key & ")" & p_j_i & " pIK:(" & I_Key & K_key & ")" & p_i_k
                p_j_k = GetMax(p_j_k, GetMin(p_j_i, p_i_k))
                Me.Edges.Item(J_Key, K_key).EdgeStrength = p_j_k
                'Debug.Print "PJK = max ((PJK) and min (pJI, pIK)). PJK = " & p_j_k
                If oldpjk <> p_j_k Then
                  Debug.Print "pJK UPDATED"
                  Debug.Print I_Key & J_Key & K_key
                  Debug.Print "pJK: (" & J_Key & K_key & ") " & oldpjk & " pJI: (" & J_Key & I_Key & ")" & p_j_i & " pIK:(" & I_Key & K_key & ")" & p_i_k
                  Debug.Print "PJK = max ((PJK) and min (pJI, pIK)). PJK = " & p_j_k
                  Debug.Print
                End If
            End If
       Next k
       End If
    Next j
  Next I
End Sub

You can probably do this without the class modules, but it makes the logic so much easier.
 

Attachments

In my class module for Edges it represent the connection between a node. So it has
StartVertex
EndVertex
Weight (the initial value going between as node) BA = 25
Strength

So I added a new property PairWinner

So now I store that for AB the winner is B and for BA the winner is B. Then I can write these back to the table. I count them up to get the rank.ing

pairwinner.jpg
 

Attachments

@spkvist
If still following this thread, this may be a "simpler" version. Since this graph will never be very big (NumberChoices X NumberChoices - 1). This may be simpler to do everything in the table. (If this was a big graph then it would be very slow.) This alleviates saving to the custom class and then writing to and from back to table and class. You can just use the table to store your calculations and look up the data in the table as you iterate. This uses your real data. I added the queries to set up the initial table of preferences.


Code:
Public Sub SolveSchultzOrder()
  Dim I_Key As String
  Dim J_Key As String
  Dim K_key As String
  Dim I As Integer
  Dim j As Integer
  Dim k As Integer
  Dim The_Keys() As String
  Dim p_j_I As Double
  Dim p_j_k As Double
  Dim p_i_k As Double
  Dim newStrengh As Double
  Dim n As Long
  Dim oldpjk As Double
  Dim rs As DAO.Recordset
 
  'Set the starting strengths in the table.
  PopulateStartingStrengths
 
  Set rs = CurrentDb.OpenRecordset("choices")
  rs.MoveLast
  rs.MoveFirst
  n = rs.RecordCount
  'Put the choices in an array
  ReDim The_Keys(n - 1)
  Do While Not rs.EOF
    The_Keys(I) = rs!Choice
    I = I + 1
    rs.MoveNext
  Loop
 
  For I = 0 To n - 1
    I_Key = The_Keys(I)
    For j = 0 To n - 1
       J_Key = The_Keys(j)
       If J_Key <> I_Key Then
       For k = 0 To n - 1
         K_key = The_Keys(k)
            If I_Key <> K_key And J_Key <> K_key Then
                p_j_I = GetStrength(J_Key, I_Key)
                p_i_k = GetStrength(I_Key, K_key)
                p_j_k = GetStrength(J_Key, K_key)
                oldpjk = p_j_k
                p_j_k = GetMax(p_j_k, GetMin(p_j_I, p_i_k))
                UpdateStrength J_Key, K_key, p_j_k
                UpdatePairWinners J_Key, K_key
            End If
       Next k
       End If
    Next j
  Next I
 
End Sub
Public Sub PopulateStartingStrengths()
  Dim strSql As String
  Dim rs As DAO.Recordset
  Dim strength1 As Double
  Dim strength2 As Double

 'If AB < BA then set its Strength to 0 else set it to the preference count
  Set rs = CurrentDb.OpenRecordset("tblNodesSchultz")
  Do While Not rs.EOF
    strength1 = rs!PreferenceCount
    strength2 = DLookup("PreferenceCount", "tblNodesSchultz", "FirstChoice = '" & rs!SecondChoice & "' AND SecondChoice = '" & rs!FirstChoice & "'")
    If strength1 < strength2 Then
       strength1 = 0
    End If
    rs.Edit
      rs!Strength = strength1
    rs.Update
    rs.MoveNext
  Loop
End Sub


Public Sub UpdatePairWinners(ByVal FirstChoice, ByVal SecondChoice)
  Dim StrengthJK As Double
  Dim strengthKJ As Double
  StrengthJK = GetStrength(FirstChoice, SecondChoice)
  strengthKJ = GetStrength(SecondChoice, FirstChoice)
  If StrengthJK >= strengthKJ Then
    UpdateWinner FirstChoice, SecondChoice, FirstChoice
    UpdateWinner SecondChoice, FirstChoice, FirstChoice
  End If
End Sub



'-------------------------------------------------------------------- Helper Functions ----------------------------------------------------------------------------------
Public Function GetStrength(ByVal FirstChoice As String, ByVal SecondChoice As String) As Double
  Dim criteria As String
  FirstChoice = "'" & FirstChoice & "'"
  SecondChoice = "'" & SecondChoice & "'"
  criteria = "Firstchoice = " & FirstChoice & " AND SecondChoice = " & SecondChoice
  Debug.Print criteria
  GetStrength = DLookup("strength", "tblNodesSchultz", criteria)
End Function
Public Sub UpdateStrength(ByVal FirstChoice As String, ByVal SecondChoice As String, Strength As Double)
  FirstChoice = "'" & FirstChoice & "'"
  SecondChoice = "'" & SecondChoice & "'"
  Dim strSql As String
  strSql = "Update tblNodesSchultz Set Strength = " & Strength & " where FirstChoice = " & FirstChoice & " AND SecondChoice = " & SecondChoice
  CurrentDb.Execute strSql
End Sub
Public Sub UpdateWinner(ByVal FirstChoice As String, ByVal SecondChoice As String, ByVal Winner As String)
  FirstChoice = "'" & FirstChoice & "'"
  SecondChoice = "'" & SecondChoice & "'"
  Winner = "'" & Winner & "'"
  Dim strSql As String
  strSql = "Update tblNodesSchultz Set PairWinner = " & Winner & " where FirstChoice = " & FirstChoice & " AND SecondChoice = " & SecondChoice
  CurrentDb.Execute strSql
End Sub

Public Function GetMin(Val1 As Double, Val2 As Double) As Double
  If Val1 <= Val2 Then
    GetMin = Val1
  Else
    GetMin = Val2
 End If
End Function
Public Function GetMax(Val1 As Double, Val2 As Double) As Double
  If Val1 >= Val2 Then
    GetMax = Val1
  Else
    GetMax = Val2
 End If
End Function
 

Attachments

Users who are viewing this thread

Back
Top Bottom