これはこのフォーラムでの最初の質問だと思うので、いくつかのルールに従わなかった場合は申し訳ありません. Shapley-Shubik インデックスを計算する VBA アルゴリズムを作成しようとしています。このインデックスでは、一連の数値 (議会、議会などでの投票を表す) のすべての順列を計算する必要があります。徹底的な調査の結果、そのようなことを実行するには再帰アルゴリズムを使用する必要があることがわかりました。
私の考えは、各要素が個別に格納され、各行に異なる順列が含まれる 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
一部の変数がイタリア語である場合は申し訳ありません。また、コードの一部はいくつかの専門フォーラムであちこちで取得されているため、特定のコマンドの功績は認めません。組み立てのためだけです :) 最後のリクエスト: 誰かがこのコードを改善できる場合は、それを共有してください誰もが使えるように。