Is there a more efficient way to calculate the cardinality set of an array?
This is my current implementation using bits:
Function Array_PowerSet(Self)
Array_PowerSet = Array()
PowerSetUpperBound = -1
For Combination = 1 To 2 ^ (UBound(Self) - LBound(Self)) ' I don't want the null set
Subset = Array()
SubsetUpperBound = -1
For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
If Combination And 2 ^ NthBit Then
SubsetUpperBound = SubsetUpperBound + 1
ReDim Preserve Self(0 To SubsetUpperBound)
Subset(SubsetUpperBound) = Self(NthBit)
End If
Next
PowerSetUpperBound = PowerSetUpperBound + 1
ReDim Preserve Array_PowerSet(0 To PowerSetUpperBound)
Array_PowerSet(PowerSetUpperBound) = Subset
Next
End Function
Please ignore the abuse of Variants. Array_Push
and Array_Size
must be understood.
I used to generate a binary string for each combination, but that involved calling another function, which was not very efficient.
Apart from using smaller options and moving external function calls internally, can this be done more efficiently?
EDIT: Here's a completely independent version.
Function Array_PowerSet(Self As Variant) As Variant
Dim PowerSet() As Variant, PowerSetIndex As Long, Size As Long, Combination As Long, NthBit As Long
PowerSetIndex = -1: Size = UBound(Self) - LBound(Self) + 1
ReDim PowerSet(0 To 2 ^ Size - 2) ' Don't want null set
For Combination = 1 To 2 ^ Size - 1
Dim Subset() As Variant, SubsetIndex As Long: SubsetIndex = -1
For NthBit = 0 To Int(WorksheetFunction.Log(Combination, 2))
If Combination And 2 ^ NthBit Then
SubsetIndex = SubsetIndex + 1
ReDim Preserve Subset(0 To SubsetIndex)
Subset(SubsetIndex) = Self(NthBit)
End If
Next
PowerSetIndex = PowerSetIndex + 1
PowerSet(PowerSetIndex) = Subset
Next
Array_PowerSet = PowerSet
End Function
And the test:
Dim Input_() As Variant, Output_() As Variant, Subset As Variant, Value As Variant
Input_ = Array(1, 2, 3)
Output_ = Array_PowerSet(Input_)
For Each Subset In Output_
Dim StringRep As String: StringRep = "{"
For Each Value In Subset
StringRep = StringRep & Value & ", "
Next
Debug.Print Left$(StringRep, Len(StringRep) - 2) & "}"
Next
source to share
Since the number of subsets grows exponentially, none of the algorithms are truly efficient, although there is room for improvement in what you are doing:
ReDim Preserve
when used to expand an array with one element is ineffective as it involves creating a new array with 1 more space and then copying the old elements into the new array. Better to preallocate enough space and then crop it to size:
Function PowerSet(Items As Variant) As Variant
'assumes that Items is a 0-based array
'returns a 0-based jagged array of subsets of Items
'where each subset is a 0-based array
Dim PS As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim subset As Variant
n = 1 + UBound(Items) 'cardinality of the base set
ReDim PS(0 To 2 ^ n - 2)
For i = 1 To 2 ^ n - 1
subset = Array()
ReDim subset(0 To n - 1)
k = -1 'will be highest used index of the subset
For j = 0 To n - 1
If i And 2 ^ j Then
k = k + 1
subset(k) = Items(j)
End If
Next j
ReDim Preserve subset(0 To k)
PS(i - 1) = subset
Next i
PowerSet = PS
End Function
Test function:
Sub test()
Dim stuff As Variant, subsets As Variant
Dim i As Long
stuff = Array("a", "b", "c", "d")
subsets = PowerSet(stuff)
For i = LBound(subsets) To UBound(subsets)
Cells(i + 1, 1).Value = "{" & Join(subsets(i), ",") & "}"
Next i
End Sub
source to share
Using Collections to Build Your Kits is an option ...
Function Generator()
Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
Dim PSCol As Collection: Set PSCol = PowerSetCol(Arr)
Dim SubSet As Collection, SubSetStr As String
For i = 1 To PSCol.Count
Set SubSet = PSCol.Item(i)
SubSetStr = "{"
For j = 1 To SubSet.Count
SubSetStr = SubSetStr & SubSet.Item(j) & IIf(j = SubSet.Count, "", ", ")
Next j
SubSetStr = SubSetStr & "}"
Debug.Print SubSetStr
Next i
End Function
Function PowerSetCol(Arr As Variant) As Collection
Dim n As Long, i As Long
Dim Temp As New Collection, SubSet As Collection
For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
Set SubSet = New Collection
For n = 0 To UBound(Arr)
If i And 2 ^ n Then SubSet.Add Arr(n)
Next n
Temp.Add SubSet
Next i
Set PowerSetCol = Temp
End Function
******* EDIT ********
It seems that accessing collections through an index is more intensive than enumeration through elements. Also; you cannot use the connection directly as @John Coleman pointed out, but it can use one line function.
Hopefully the below code is a better solution
Function Generator()
Dim Arr() As Variant: Arr = Array(1, 2, 3, 4)
Dim PSColl As Collection: Set PSColl = PowerSetColl(Arr)
Dim Str As String, Coll As Collection, Item As Variant
For Each Coll In PSColl
Str = ""
For Each Item In Coll
Str = strJoin(", ", Str, CStr(Item))
Next Item
Debug.Print "{" & Str & "}"
Next Coll
End Function
Function PowerSetColl(Arr As Variant) As Collection
Dim Temp As New Collection, SubSet As Collection
Dim n As Long, i As Long
For i = 1 To 2 ^ (UBound(Arr) + 1) - 1
Set SubSet = New Collection
For n = 0 To UBound(Arr)
If i And 2 ^ n Then SubSet.Add Arr(n)
Next n
Temp.Add SubSet
Next i
Set PowerSetColl = Temp
End Function
Function strJoin(Delimiter As String, Optional Str1 As String, Optional Str2 As String) As String
strJoin = IIf(IsMissing(Str1) Or Str1 = "", Str2, IIf(IsMissing(Str2) Or Str2 = "", Str1, Str1 & Delimiter & Str2))
End Function
source to share