arrays - 在 VBA 中排列数组以计算 Shapley-Shubik 功率指数

Question

我想这是我在这个论坛上的第一个问题，如果我错过了一些规则，请原谅。我正在尝试编写一个 VBA 算法来计算 Shapley-Shubik 指数。该索引需要计算一系列数字的所有排列(代表议会、国会等的投票)。经过一些彻底的研究，我明白必须使用递归算法来执行这样的事情。

我的想法是在 vba 中创建一个矩阵，其中每个元素单独存储，并且每一行包含不同的排列。这是我随后可以执行计算并检索计算此类索引所需的正确标签值的唯一方法。
问题是我无法理解一旦达到最后一个递归级别，如何恢复到以前的级别。

(编辑)最终，我能够想出一个解决方案。我在下面发布结果，因为我已经看到它已被要求。不过我应该警告一下，这是一个非常低效的代码，并且它不适用于超过 7 个玩家。这样做的原因是因为 vba 无法处理这段代码创建的非常大的矩阵，所以程序只是因为溢出错误而崩溃。

然而，在编写这段代码时并不是特别聪明，这意味着修改代码应该很容易，以使其适用于更多的玩家。基本上，无需使用置换函数来创建矩阵，只需计算每个特定置换中的关键参与者，然后使用数组“存储”频率。不幸的是，我没有时间修改代码，因为我目前正在处理其他项目，虽然有些相关，但使用 Matlab 代替。

这是我组装的功能:

Public Function ShapleyShubik( _
  Votes As Range, _
  Coalitions As Range, _
  Candidate As String, _
  Threshold As Double) As Double
'
'------------------------------------------------------
'                    by Sim1
'  This function computes the Shapley-Shubik Power Index
'  For a specified coalition among the available ones
'------------------------------------------------------
'
Dim Labels() As String
Dim Powers() As Double
Dim Interval As Variant
Dim MatLabels() As String
Dim MatPowers() As Integer
Dim Calc() As String
Dim Total As Integer
Dim ii As Integer

'Convert Labels Range
Interval = ToArray(Coalitions)
ReDim Labels(1 To UBound(Interval)) As String
For ii = 1 To UBound(Interval)
    Labels(ii) = CStr(Interval(ii))
Next

'Convert Powers Range
Interval = ToArray(Votes)
ReDim Powers(1 To UBound(Interval)) As Double
For ii = 1 To UBound(Interval)
    Powers(ii) = CInt(Interval(ii))
Next

SShubCalc Powers, Labels, Calc, Threshold, Total

'Compute Index
ShapleyShubik = (UBound(Filter(Calc, Candidate, True)) + 1) / Total

End Function
Private Function SShubCalc( _
    ByRef Powers() As Double, _
    ByRef Labels() As String, _
    ByRef Pivotal() As String, _
    ByVal bar As Double, _
    ByRef Righe As Integer) As Boolean

On Error GoTo Error_line

Dim Colonne As Integer
Dim MatNum() As Double
Dim MatStr() As String
Dim Threshold As Integer
Dim Somma() As Double
Dim perfsum() As Boolean
Dim PivPos() As Integer
Dim Addend() As Double
Dim v() As Variant

' Define Size Variables
Colonne = UBound(Powers)
Righe = Factorial(Colonne)

'Generate Matrix of Permutations
MatrPerm Powers, MatNum, Labels, MatStr

'Provide Vector Sums and Check Threshold
With Application.WorksheetFunction
Threshold = .Sum(.index(MatNum, 1))
End With

'Control for unanimity
If (Threshold * bar) < (Threshold - 1) Then
Threshold = Round(Threshold * bar, 0) + 1
End If

'Initialize Arrays
ReDim perfsum(1 To Righe)
ReDim PivPos(1 To Righe)
ReDim Pivotal(1 To Righe)

For ii = 1 To Colonne
'First Iteration
If ii = 1 Then
v = Application.WorksheetFunction.index(MatNum, 0, ii)
ToDoubleArray Somma, v
Else:
v = Application.WorksheetFunction.index(MatNum, 0, (ii))
ToDoubleArray Addend, v
SumVector Somma, Somma, Addend
End If
For j = 1 To Righe
If Somma(j) >= Threshold And perfsum(j) = False Then
PivPos(j) = ii
perfsum(j) = True
End If
Next j
Next ii

'Transfer PivoPos to Labels
For ii = 1 To Righe
Pivotal(ii) = MatStr(ii, PivPos(ii))
Next ii

SShubCalc = True
Exit Function
Error_line:
SShubCalc = False
End Function
Private Function nextPerm(s As String)
' inspired by http://stackoverflow.com/questions/352203/generating-permutations-lazily
' this produces the "next" permutation
' it allows one to step through all possible iterations without having to have them
' all in memory at the same time
Dim L As Integer, ii As Integer, jj As Integer
Dim c() As Byte, temp As Byte

L = Len(s)

If StrComp(s, "**done**") = 0 Or StrComp(s, "") = 0 Then
  nextPerm = ""
  Exit Function
End If

' convert to byte array... more compact to manipulate
ReDim c(1 To L)
For ii = 1 To L
  c(ii) = Asc(Mid(s, ii, 1))
Next ii

' find the largest "tail":
For ii = L - 1 To 1 Step -1
  If c(ii) < c(ii + 1) Then Exit For
Next ii

' if we complete the loop without break, ii will be zero
If ii = 0 Then
  nextPerm = "**done**"
  Exit Function
End If

' find the smallest value in the tail that is larger than c(ii)
' take advantage of the fact that tail is sorted in reverse order
For jj = L To ii + 1 Step -1
  If c(jj) > c(ii) Then
    ' swap elements
    temp = c(jj)
    c(jj) = c(ii)
    c(ii) = temp
    Exit For
  End If
Next jj

' now reverse the characters from ii+1 to the end:
nextPerm = ""
For jj = 1 To ii
  nextPerm = nextPerm & Chr(c(jj))
Next jj
For jj = L To ii + 1 Step -1
  nextPerm = nextPerm & Chr(c(jj))
Next jj

'Debug.Print nextPerm

End Function
Private Function Factorial(dblNumber As Integer) As Integer

Dim dblCtr As Double
Dim dblResult As Double

dblResult = 1 'initializes variable
For dblCtr = 1 To dblNumber
dblResult = dblResult * dblCtr
Next dblCtr

Factorial = dblResult

End Function
Private Function SumVector(ByRef Result() As Double, ByRef Vec1() As Double, ByRef Vec2() As Double)

Dim temp As Integer
Dim tempuno As Integer
Dim ii As Integer

If LBound(Vec1) = 0 Then
temp = UBound(Vec2)
ReDim Preserve Vec1(1 To (temp + 1))
End If

If LBound(Vec2) = 0 Then
tempuno = UBound(Vec2)
ReDim Preserve Vec2(1 To (temp + 1))
End If

If temp <> tempuno Then
Exit Function
End If

ReDim Preserve Result(1 To UBound(Vec1))

'Debug.Print Vec1(1, 1)

For ii = 1 To UBound(Vec1)
Result(ii) = Vec1(ii) + Vec2(ii)
Next ii

End Function
Private Function ToDoubleArray( _
    ByRef DoubleArray() As Double, _
    ByRef VariantArray() As Variant)

If LBound(VariantArray) = 0 Then
ReDim Preserve VariantArray(1 To (UBound(VariantArray) + 1))
End If

ReDim DoubleArray(1 To UBound(VariantArray))

For ii = 1 To UBound(VariantArray)
DoubleArray(ii) = VariantArray(ii, 1)
Next ii

End Function
Private Function MatrPermStr( _
    ByRef VecInput() As String, _
    ByRef MatOutput() As String)

Dim Sequence As String
Dim StrPerm As String
Dim Colonne As Integer
Dim Righe As Integer
Dim ii As Integer
Dim j As Integer


' Size Variables
Colonne = UBound(VecInput)
Righe = Factorial(Colonne)

ReDim MatOutput(1 To Righe, 1 To Colonne) As String

'Start With an Empty Sequence
Sequence = ""

'Create Sequence with defined Length
For ii = 1 To Colonne
Sequence = Sequence & ii
Next ii

'Assign the permutation to the array
For j = 1 To Righe
If j = 1 Then
StrPerm = Sequence
Else
StrPerm = nextPerm(StrPerm)
End If
For ii = 1 To Colonne
MatOutput(j, ii) = VecInput(Mid(StrPerm, ii, 1))
Next ii
Next j

End Function
Private Function MatrPerm( _
    ByRef VecInput() As Double, _
    ByRef MatOutput() As Double, _
    ByRef VecInputStr() As String, _
    ByRef MatOutputStr() As String)

Dim Sequence As String
Dim StrPerm As String
Dim Colonne As Integer
Dim Righe As Integer
Dim ii As Integer
Dim j As Integer
Dim t As Integer

' Size Variables
Colonne = UBound(VecInput)
Righe = Factorial(Colonne)

ReDim MatOutput(1 To Righe, 1 To Colonne)
ReDim MatOutputStr(1 To Righe, 1 To Colonne)

'Start With an Empty Sequence
Sequence = ""

'Create Sequence with defined Length
For ii = 1 To Colonne
Sequence = Sequence & ii
Next ii

'Assign the permutation to the array
For j = 1 To Righe
If j = 1 Then
StrPerm = Sequence
Else
StrPerm = nextPerm(StrPerm)
End If
For ii = 1 To Colonne
MatOutput(j, ii) = VecInput(Mid(StrPerm, ii, 1))
MatOutputStr(j, ii) = VecInputStr(Mid(StrPerm, ii, 1))
Next ii
Next j

End Function
Private Function ToArray(ByRef someRange As Range) As Variant

Dim someValues As Variant

With someRange
    If .Cells.Count = 1 Then
        ReDim someValues(1 To 1)
        someValues(1) = someRange.Value
    ElseIf .Rows.Count = 1 Then
        someValues = Application.Transpose(Application.Transpose(someRange.Value))
    ElseIf .Columns.Count = 1 Then
        someValues = Application.Transpose(someRange.Value)
    Else
        MsgBox "someRange is mutil-dimensional"
    End If
End With

ToArray = someValues

End Function

Private Sub DescribeShapShub()
   Dim FuncName As String
   Dim FuncDesc As String
   Dim Category As String
   Dim ArgDesc(1 To 4) As String

   FuncName = "SHAPLEYSHUBIK"
   FuncDesc = "Returns Shapley-Shubik power index for a given player, given the other players' votes"
   Category = 3 'Math category
   ArgDesc(1) = "Range containing the player's votes (Only selected votes will be considered in the computation)"
   ArgDesc(2) = "Range containing the player's names (must have the same length as ""Votes"")"
   ArgDesc(3) = "Cell or String containing the player for which to compute the index"
   ArgDesc(4) = "Cell or Number containing the voting threshold (e.g. 0.5 for 50%)"

   Application.MacroOptions _
      Macro:=FuncName, _
      Description:=FuncDesc, _
      Category:=Category, _
      ArgumentDescriptions:=ArgDesc

End Sub

对不起，如果有些变量是意大利语。此外，代码的某些部分已经在一些专门的论坛中到处检索，所以我不相信具体的命令，只是为了组装:)
最后一个请求:如果有人能够改进此代码，请分享它，以便每个人都可以使用它。

Answer 1

我不会准确回答你的问题；但我想为您提供一个不错的小功能，可以帮助您解决更大的问题。此函数生成字符串的“下一个”排列 - 其中字符串可以包含数字或字母，而“下一个”是字典意义上的(参见 [本讨论]( Generating permutations lazily
))。

你能用它做什么？好吧，当您想“在所有可能的排列上”计算任何东西时，拥有一个为您提供“只是下一个排列”的函数将使您的代码保持可读性(它消除了大量的内务管理!)。然后你可以简单地说(这是伪代码):

// initialize stuff
firstPerm = "1234"
np = nextPerm(firstPerm)

// loop over all permutations
while not np equals "done"
    // update calculations on np
    np = nextPerm(np)
wend

// report your results  

这是功能。它对我来说似乎表现得很好——即使我在字符串中有多个相同的字符，或者是字母和数字的混合。请注意，它处理 A和 a as distinct... 另请注意，完成后它会返回字符串“done”。显然，如果您碰巧将字符串 "doen" 传递给它，作为输入，它会返回“完成”，尽管它没有完成......尽量避免这种情况!

  Function nextPerm(s As String)
' inspired by https://stackoverflow.com/questions/352203/generating-permutations-lazily
' this produces the "next" permutation
' it allows one to step through all possible iterations without having to have them
' all in memory at the same time
Dim L As Integer, ii As Integer, jj As Integer
Dim c() As Byte, temp As Byte

L = Len(s)

If StrComp(s, "**done**") = 0 Or StrComp(s, "") = 0 Then
  nextPerm = ""
  Exit Function
End If

' convert to byte array... more compact to manipulate
ReDim c(1 To L)
For ii = 1 To L
  c(ii) = Asc(Mid(s, ii, 1))
Next ii

' find the largest "tail":
For ii = L - 1 To 1 Step -1
  If c(ii) < c(ii + 1) Then Exit For
Next ii

' if we complete the loop without break, ii will be zero
If ii = 0 Then
  nextPerm = "**done**"
  Exit Function
End If

' find the smallest value in the tail that is larger than c(ii)
' take advantage of the fact that tail is sorted in reverse order
For jj = L To ii + 1 Step -1
  If c(jj) > c(ii) Then
    ' swap elements
    temp = c(jj)
    c(jj) = c(ii)
    c(ii) = temp
    Exit For
  End If
Next jj

' now reverse the characters from ii+1 to the end:
nextPerm = ""
For jj = 1 To ii
  nextPerm = nextPerm & Chr(c(jj))
Next jj
For jj = L To ii + 1 Step -1
  nextPerm = nextPerm & Chr(c(jj))
Next jj

End Function

您只需将其添加到电子表格中的 VBA 模块，然后使用 .xlsm 保存工作簿即可对其进行测试。扩大。然后你可以输入 =nextPerm("abcd")在单元格中 A1 ，它应该给你下一个排列 - "abdc" .打字 =nextPerm(A1)在 A2 中将计算之后的那个，等等。您可以一直复制电子表格，并获取每个值。

如果将单元格复制到超出最后一个排列的范围，它将返回 "**done**"作为第一次发生这种情况的值(value)；当你喂它时"**done**"作为输入，它将返回空白。这使得事情停止的地方很明显。