在VBA中置换数组以计算Shapley-Shubik幂指数

我想这是我在这个论坛上的第一个问题，如果我错过了一些规则，请原谅。我正在尝试编写一个VBA算法来计算Shapley-Shubik索引。这个索引需要计算一系列数字的所有排列（代表议会、国会等中的选票）。经过一番彻底的研究，我明白了必须使用递归算法才能完成这项工作。

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

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

然而，in在编写此代码时并不是特别聪明，这意味着修改代码应该非常容易，以便使其适用于更多的玩家。基本上，不需要使用排列函数来创建矩阵，只需要计算每个特定排列中的关键参与者，然后使用数组来"存储"频率。不幸的是，我没有时间修改代码，因为我目前正在进行其他项目，尽管有些相关，但使用的是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

很抱歉，如果某些变量是意大利语。此外，代码的某些部分已经在一些专门的论坛上到处检索到，所以我不相信特定的命令，只相信组装：）最后一个请求：如果有人能够改进这个代码，请分享它，这样每个人都可以使用它。