is it possible to use stdenumerator for alternative to yield python code

[JurassicPork]

Hello,
i need to convert python code with yield enumerator to VBA code :

def gen_subsets(sous_ensembles, element,somme_groupe):
    # fonction permettant de générer les nouveaux sous-ensembles après ajout de l'élément
    # parcours des sous-ensembles (subset)
    for subset in sous_ensembles:
        # ordre de renvoyer le sous-ensemble : descente à gauche dans l'arbre binaire
        yield subset
        # création du nouveau sous-ensemble avec ajout du nouvel élément
        new_subset = tuple(subset) + (element,)
        # ordre de renvoyer le nouveau sous-ensemble  : descente à droite dans l'arbre binaire
        if sum(new_subset)<=somme_groupe:
            yield new_subset

my actual VBA code ( works but slower x30 than python . Tuples replaced by collection) :

Function GenSubsets(Subsets As Collection, Element As Variant, GroupSum As Double) As Collection
    ' Function to generate new subsets after adding the element
    Dim NewSubset As Collection
    Dim Subset As Variant
    Set GenSubsets = New Collection
    For Each Subset In Subsets
        ' Return the subset
        GenSubsets.Add Subset
        ' Create the new subset with the new element added
        Set NewSubset = New Collection
        Dim Item As Variant
        For Each Item In Subset
            NewSubset.Add Item
        Next Item
        NewSubset.Add Element
        If SumCollection(NewSubset) <= GroupSum Then
            GenSubsets.Add NewSubset
        End If
    Next Subset
End Function

Function SumCollection(ByVal Col As Collection) As Double
    Dim Total As Double
    Total = 0
    Dim Item As Variant
    For Each Item In Col
        Total = Total + Item
    Next Item
    SumCollection = Total
End Function

Elements are Double Example :

Array(56.94624, 39.104, 27.98432, 26.9568, 60.54048, 48.8072, 49.55808, 31.85, 50.752, 55.3696, _
                            46.78128, 34.80048, 38.75508, 55.13664, 39.3354, 37.37448, 80.3374, 19.24208, 12.3786)

GroupSum = 135,33502

i guess that yield reduces the number of generated subsets.

Thanks !

[sancarn]

You're creating a new collection each round trip, that's bound to be slow. I'd be using arrays if I were you and ensuring memory re-use where ever possible. Maybe even a UDT which can keep track of sum of each subset too:

Type SumSubset
  sum as Double
  count as Long
  subset() as Double
End Type
Function SumSubset_AppendElement(subset as SumSubset, element as double) as SumSubset
  Dim t as SumSubset
  LSet t = subset
  t.sum = t.sum + element
  t.count = t.count + 1
  redim preserve t.subset(1 to t.count)
  t.subset(t.count) = element
  LSet SumSubset_AppendElement = t
End Function

In answer to your question you can't do any type of yield in VBA, as it would basically require hacking the runtime. It's possible we could add something like a yield to stdLambda but this isn't a current field I'm afraid.

[sancarn]

So correct me if I'm wrong, but you're just creating a set of perturbation groups initially? And then essentially filtering out those perturbations that sum to a value exceeding your group total?

[JurassicPork]

the goal : in a group of 19 values find 6 groupes of 3 or 4 values ( 6 , 3 , 4 are parameters) with the sum of the groups nearest the GroupSum -> Sum of the 19 values / number of groupes (6)
i try n times and each time i shuffle the 19 values. With that , i find the optimal solution under of 50 times. Algorithm seems to be OK
the only problem is the performance in the generation of subsets

[JurassicPork]

Hello,

You're creating a new collection each round trip, that's bound to be slow

i have done some tests of performance with some object containers ( ArrayList, List, Collection, stdArray, BetterArray)
code for 10000 create , Add elements, Read Elements

Sub TestPerf()
Dim bm As New cBenchmark
Dim i As Long, nbIter As Long, rdVal As Double, Value As Variant
Dim myArrLst As Object, myLst As List, myCol As Collection
Dim myStdArray As stdArray, myBetterArr As BetterArray
nbIter = 10000
Set myArrLst = CreateObject("System.Collections.ArrayList")
bm.TrackByName "Init"
For i = 1 To nbIter
Set myArrLst = CreateObject("System.Collections.ArrayList")
Next
bm.TrackByName "Create myArrLst"
For i = 1 To nbIter
Set myLst = New List
Next
bm.TrackByName "Create List"
For i = 1 To nbIter
Set myCol = New Collection
Next
bm.TrackByName "Create Collection"
For i = 1 To nbIter
Set myStdArray = stdArray.Create()
Next
bm.TrackByName "Create StdArray"
For i = 1 To nbIter
Set myBetterArr = New BetterArray
Next
bm.TrackByName "Create BetterArray"


For i = 1 To nbIter
   myArrLst.Add CDbl(i)
Next
bm.TrackByName "Add elems to myArrLst"
For i = 1 To nbIter
    myLst.Add CDbl(i)
Next
bm.TrackByName "Add elems to List"
For i = 1 To nbIter
   myCol.Add CDbl(i)
Next
bm.TrackByName "Add elems to Collection"
For i = 1 To nbIter
   myStdArray.Push CDbl(i)
Next
bm.TrackByName "Add elems to StdArray"
For i = 1 To nbIter
   myBetterArr.Push CDbl(i)
Next
bm.TrackByName "Add elems to BetterArray"

For Each Value In myArrLst
    rdVal = Value
Next
bm.TrackByName "Read elems from ArrayLst"
For i = 1 To nbIter
    rdVal = myLst.Item(i - 1)
Next
bm.TrackByName "read elems from List"
For Each Value In myCol
    rdVal = Value
Next
bm.TrackByName "read elems from Collection"
For Each Value In myStdArray
    rdVal = Value
Next
bm.TrackByName "read elems from StdArray"
For i = 1 To nbIter
    rdVal = myBetterArr(i - 1)
Next
bm.TrackByName "read elems from BetterArray"
End Sub

Résult

IDnr	Name	Count	Sum of tics	Percentage	Time sum
0	Init	1	65	0,00%	6500 ns
1	Create myArrLst	1	4 701 833	61,03%	470 ms
2	Create List	1	211 019	2,74%	21 ms
3	Create Collection	1	25 235	0,33%	2,52 ms
4	Create StdArray	1	250 607	3,25%	25 ms
5	Create BetterArray	1	1 910 952	24,80%	191 ms
6	Add elems to myArrLst	1	348 150	4,52%	35 ms
7	Add elems to List	1	32 002	0,42%	3,2 ms
8	Add elems to Collection	1	10 249	0,13%	1,02 ms
9	Add elems to StdArray	1	37 310	0,48%	3,73 ms
10	Add elems to BetterArray	1	77 329	1,00%	7,73 ms
11	Read elems from ArrayLst	1	47 863	0,62%	4,79 ms
12	read elems from List	1	20 272	0,26%	2,03 ms
13	read elems from Collection	1	4 134	0,05%	413 us
14	read elems from StdArray	1	12 951	0,17%	1,3 ms
15	read elems from BetterArray	1	14 495	0,19%	1,45 ms
TOTAL	16	7 704 466	100,00%	770 ms
Total time recorded:	770 ms

Collection is fast. It is the fastest. ArrayList is the Slowest

[JurassicPork]

sancarn
In answer to your question you can't do any type of yield in VBA, as it would basically require hacking the runtime. It's possible we could add something like a yield to stdLambda but this isn't a current field I'm afraid.

Thanks for this answer. So don't spend more time on this problem. I have found another solution --> i have written a function in csharp language (yield exists in this language) and use Excel-Dna to call it and get the solution in VBA. Under one second to have the solution.

[sancarn]

Collection is fast. It is the fastest. ArrayList is the Slowest

Yes, ArrayList will absolutely be slower because it's late bound. Same with stdArray, stdVBA classes are designed for usability not performance.

Arrays, i.e. Dim subsets() As SumSubset, will be guaranteed the fastest solution, but you would need to rework your code base.

Anyhow, glad you got a solution that works :)

[JurassicPork]

Hello
Ultimately i have found how to use your UDT in my code :

Public bm As cBenchmark
Type SumSubset
  sum As Double
  Count As Long
  subset() As Double
End Type
Function TestSubset(NumberOfElements As Long, NumberOfValues As Long, MinimumElements As Long, MaximumElements As Long, RemainingGroups As Long) As Boolean
    TestSubset = ((NumberOfValues - NumberOfElements) >= (RemainingGroups * MinimumElements)) And ((NumberOfValues - NumberOfElements) <= (RemainingGroups * MaximumElements))
End Function

'Appends an element to a sum subset, increments count and sum accordingly
'@param subset - to append element to
'@param element - Element to append to SumSubset
'@returns - New `SumSubset`. Original is unaltered
Function SumSubset_AppendElement(subset As SumSubset, Element) As SumSubset
  Dim t As SumSubset
  LSet t = subset
  t.sum = t.sum + Element
  t.Count = t.Count + 1
  ReDim Preserve t.subset(1 To t.Count)
  t.subset(t.Count) = Element
  LSet SumSubset_AppendElement = t
End Function

Function SumSubset_ToCol(subset As SumSubset) As Collection
   Set SumSubset_ToCol = New Collection
   For i = LBound(subset.subset) To UBound(subset.subset)
      SumSubset_ToCol.Add subset.subset(i)
   Next i
End Function

'Append element to an array of subsets
'@param subsets - An array of `SumSubset`s
'@param subset - `SumSubset` to append to the array
Sub SumSubsets_AppendSubset(subsets() As SumSubset, subset As SumSubset)
  ReDim Preserve subsets(LBound(subsets) To UBound(subsets) + 1)
  subsets(UBound(subsets)) = subset
End Sub
Function GenSubsets(subsets() As SumSubset, Element, GroupSum As Double) As SumSubset()
  'Copy all subsets to new subsets, we will only add additional subsets with loop below
  GenSubsets = subsets
  
  'Loop over subsets, appending element and checking if this hsould be added to the result
  Dim i As Long
  For i = LBound(subsets) To UBound(subsets)
    Dim tNew As SumSubset
    tNew = SumSubset_AppendElement(subsets(i), Element)
    If tNew.sum <= GroupSum Then
      Call SumSubsets_AppendSubset(GenSubsets, tNew)
    End If
  Next
End Function

Function GenerateSubsets(Elements As Collection, GroupSum As Double) As SumSubset()
'    Set subsets = New Collection
'    subsets.Add New Collection ' Start with an empty subset
    Dim subsets() As SumSubset
    ReDim subsets(0 To 0)
    Dim Element As Variant
    For Each Element In Elements
        subsets = GenSubsets(subsets, Element, GroupSum)
    Next Element
    ' Return the generator to iterate through the obtained subsets
    GenerateSubsets = subsets
End Function

Sub CalculCol2()
    Dim ws As Worksheet, NbIters As Long, arrVal
    Dim NumberOfGroups As Long, MinimumElements As Long, MaximumElements As Long
    Set ws = Worksheets("Répartition")
    Set bm = New cBenchmark
    bm.TrackByName "Start"
    NumberOfGroups = ws.Range("NbGroupes").Value
    MinimumElements = ws.Range("MinElem").Value
    MaximumElements = ws.Range("MaxElem").Value
    NbIters = ws.Range("NbIters").Value
    arrVal = WorksheetFunction.Transpose(ws.Range("Valeurs"))
    ws.Range("NumEssai").Value = 0
    Dim Values As Collection
    Set Values = New Collection
    Dim OriginalValues As Object
    Set OriginalValues = CreateObject("System.Collections.ArrayList")
    Dim Value As Variant
    'For Each Value In Array(56.94624, 39.104, 27.98432, 26.9568, 60.54048, 48.8072, 49.55808, 31.85, 50.752, 55.3696, _
    '                        46.78128, 34.80048, 38.75508, 55.13664, 39.3354, 37.37448, 80.3374, 19.24208, 12.3786)
     For Each Value In arrVal
        Values.Add CDbl(Value)
        OriginalValues.Add CDbl(Value)
    Next Value
    Set Values = ShuffleCollection(Values)
    'NumberOfGroups = 7
    Dim Deviation As Double
    Deviation = 0
    Dim GroupSum As Double
    GroupSum = SumCollection(Values) / NumberOfGroups
    Debug.Print GroupSum
    'MinimumElements = 2
    'MaximumElements = 3
    Randomize
    Dim MaximumDeviation As Double
    MaximumDeviation = 9999
    Dim n As Long, i As Long, cpti As Long
    Dim Numbers As Collection, GroupList As Collection
    Dim subset As SumSubset, ValueInSubset As Variant
    Dim gSubsets() As SumSubset, k As Long, p As Long
    For n = 0 To NbIters
        Debug.Print n
        Deviation = 0
        ws.Range("NumEssai").Value = n
        Do While Deviation <= 10
            Set Numbers = CloneCollection(Values)
            Set GroupList = New Collection
            For i = 0 To NumberOfGroups - 2
                cpti = i
                gSubsets = GenerateSubsets(Numbers, GroupSum + Deviation)
                For k = LBound(gSubsets) To UBound(gSubsets)
                subset = gSubsets(k)
                'For Each subset In GenerateSubsets(Numbers, GroupSum + Deviation)
                    ' If the sum of the integers in the subset is equal to GroupSum plus or minus the deviation
                    If Abs(subset.sum - GroupSum) <= Deviation Then
                        If (subset.Count >= MinimumElements) And (subset.Count <= MaximumElements) _
                            And TestSubset(subset.Count, Numbers.Count, MinimumElements, MaximumElements, (NumberOfGroups - i - 1)) Then
                            ' Add the subset of numbers
                            GroupList.Add SumSubset_ToCol(subset)
                            For p = LBound(subset.subset) To UBound(subset.subset)
                                RemoveFromCollection Numbers, subset.subset(p)
                            Next
                            Exit For
                        End If
                    End If
                Next
                If GroupList.Count = i Then
                    Exit For ' Exit the loop
                End If
            Next i
            
            If GroupList.Count > cpti Then
             '   Debug.Print "Exit cpti"
                Exit Do ' Exit the loop
            End If
            
            Deviation = Deviation + 0.1 ' Increment the deviation for a search
        Loop
       ' Debug.Print "Fin Loop"
       GroupList.Add Numbers ' Add the last group to the list
        
        Dim SumsGroups As Collection
        Set SumsGroups = New Collection
        Dim LengthsGroups As Collection
        Set LengthsGroups = New Collection
        Dim Group As Variant
        For Each Group In GroupList
            SumsGroups.Add SumCollection(Group)
            LengthsGroups.Add Group.Count
        Next Group
        Dim MaxDeviation As Double
        MaxDeviation = MaxCollection(SumsGroups) - MinCollection(SumsGroups)
        If MaxDeviation < MaximumDeviation Then
            Debug.Print "n : " & n & " -> max deviation = " & MaxDeviation
            MaximumDeviation = MaxDeviation
            i = 1
            Dim elem As Variant, subelem As Variant
            ReDim grpVal(0 To OriginalValues.Count - 1) As Integer
            For Each elem In GroupList
                For Each subelem In elem
                    grpVal(OriginalValues.IndexOf(subelem, 0)) = i
                Next subelem
            i = i + 1
            Next elem
            ws.Range("Groupes").Value2 = Application.Transpose(grpVal)
        End If
        Set Values = ShuffleCollection(Values)
    Next n
    bm.TrackByName "End"
End Sub

Function SumCollection(ByVal Col As Collection) As Double
    Dim Total As Double
    Total = 0
    Dim item As Variant
    For Each item In Col
        Total = Total + item
    Next item
    SumCollection = Total
End Function
Sub RemoveFromCollection(ByRef Col As Collection, item As Variant)
    Dim i As Long
    For i = Col.Count To 1 Step -1
        If Col(i) = item Then
            Col.Remove i
        End If
    Next i
End Sub
Function ShuffleCollection(ByVal Col As Collection) As Collection
    Set ShuffleCollection = New Collection
    Randomize
    Do While Col.Count > 0
        Dim randomIndex As Integer
        randomIndex = Int(Rnd() * Col.Count) + 1
        ShuffleCollection.Add Col(randomIndex)
        Col.Remove randomIndex
    Loop
End Function
Function CloneCollection(ByVal Col As Collection) As Collection
    Dim elem As Variant
    Set CloneCollection = New Collection
    For Each elem In Col
        CloneCollection.Add elem
    Next elem
End Function
Function MaxCollection(ByVal Col As Collection) As Double
    Dim Max As Double
    Max = 0
    Dim item As Variant
    For Each item In Col
        If item > Max Then Max = item
    Next item
    MaxCollection = Max
End Function
Function MinCollection(ByVal Col As Collection) As Double
    Dim Min As Double
    Min = 99999
    Dim item As Variant
    For Each item In Col
        If item < Min Then Min = item
    Next item
    MinCollection = Min
End Function

UDT is faster than Collection :
with SumSubset UDT : Total time recorded: 11,2 s
with Collection : Total time recorded: 15,2 s
But using yield with Javascript or Csharp is faster :

with Call to Javascript Function (yield instructions included) : Total time recorded: 2,27 s
with Call to ExcelDna (Csharp) Function (yield instructions included) : Total time recorded: 129 ms

Friendly, J.P

[sancarn]

It definitely surprises me that calling out to a separate interpreted runtime is faster than compiled vba... Are you sure it's a like for like comparrison?

[JurassicPork]

vba code for xldna Csharp test :

Sub CalcRepart()
Dim Utils As Object, i As Integer, J As Integer, nbGrps As Integer
Dim MinElem As Integer, MaxElem As Integer, res, Res1D, str
Dim bm As New cBenchmark
Set Utils = CreateObject("XlDnaJP.Utils")
bm.TrackByName "Init"
nbGrps = Range("NbGroupes").value
MinElem = Range("MinElem").value
MaxElem = Range("MaxElem").value
res = Utils.CalculSoluce("Valeurs", nbGrps, MinElem, MaxElem, "Groupes")
bm.TrackByName "CalculSoluce"
End Sub

XlDnaJP is a Csharp assembly that i have included into the xll Excel dna complement. Utils is a class in this assembly. CalculSoluce is a function in the Utils class. I don't use res returned value function because into the CalculSoluce , i use the named range "Valeurs" to read the input values from the worksheet and the named range "Groupes" to update the column B of the worksheet (number of group).
Part of Csharp code to read the range of values and write the result values :

        public Object[] calculSoluce(string namedRngVal, int nb_groupes, int minElem, int maxElem,string namedRngGrp)
        {
            dynamic Excel = ExcelDnaUtil.Application;
            object[,] valeurs = Excel.Range[namedRngVal].Value2;
            object[,] numgrps = Excel.Range[namedRngGrp].Value2;
// ....
           Excel.Range[namedRngGrp].Value2 = numgrps;
            return grps;
        }

[sancarn]

Haha I meant the code which performs the calculation, are you sure that's equivalent?

Anyhow I think I see the issue now. In your VBA you're generating the subsets every cycle. You'd be much better off generating all possible subsets first, and then performing your sums. However this would be a brute force which may be slow on large datasets, which I guess is why you're using generators and randomness instead.

Generator code is definitely transferrable, but you basically have to invert your algorithm:

for each subset in subsets:
  if processResult(subset) then Exit For
  new_subset = Append(subset, element)
  if sum(new_subset) <= sum:
    if processResult(new_subset) then Exit For
  end if
next

It's definitely not as clean though, and if your xldna is sub 1s anyway, I'd keep using that :)

Does make me think though, I could certainly add a few things to stdVBA

stdEnumerator.eachFixedLengthCombination(callback, numberOfItems)
and adding yield to stdLambda