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

时间：2013-02-07 16:09:10

标签： arrays excel vba multidimensional-array permutation

我认为这是我在这个论坛的第一个问题，如果我错过了一些规则，请原谅。我正在尝试编写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

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

2 个答案:

答案 0 :(得分：0)

我不打算完全回答你的问题;但我想为您提供一个很好的小功能，有助于解决您的更大问题。此函数生成字符串的“下一个”排列 - 其中字符串可以包含数字或字母，“next”是字典意义上的（参见[this discussion]（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视为不同...另请注意，它在完成时会返回字符串“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"。在A2中键入=nextPerm(A1)将计算之后的那个，等等。您可以在电子表格中一直复制，并获得每个值。

如果将单元格复制到超出最后一个排列的范围，它将首次返回"**done**"作为值;当您输入"**done**"作为输入时，它将返回空白。这使得事情停止显而易见。

答案 1 :(得分：0)

看看这个函数 - 它将使用递归列出一组数字的所有可能的排列。 http://www.vb-helper.com/howto_permute.html

适用于VB6，但它基本上应该在Excel's的{​​{1}}实施中工作。

无论如何，我知道我不应该在答案中回答其他评论，我真的很抱歉。只是作者Simone S说“如果有人有兴趣使用结果函数只是问我”，但是，没有办法联系除此之外的人。西蒙娜，我一直在寻找VBA几个小时。能否请您指出如何计算索引或结果函数？

相关问题
最新问题