Return the largest disjoint and contiguous subsets ranging from size 1 to L among N positive numbers

Question

I'm trying to generalize the algorithm Paul Hankin provided in Maximizing the overall sum of K disjoint and contiguous subsets of size L among N positive numbers such that the solution is not limited to each subset being exactly size L and where the goal is not to maximize the overall sum, but to return the set with the largest subsets possible.

Spelling out the details, X is a set of N positive real numbers: X={x[1],x[2],...x[N]} where x[j]>=0 for all j=1,...,N.

A contiguous subset called S[i] consists of up to L consecutive members of X starting at position n[i] and ending at position n[i]+l-1:

S[i] = {x[j] | j=n[i],n[i]+1,...,n[i]+l-1} = {x[n[i]],x[n[i]+1],...,x[n[i]+l-1]}, where l=1,...,L.

Two of such subsets S[i] and S[j] are called pairwise disjoint (non-overlapping) if they don't contain any identical members of X.

Define the summation of the members of each subset:

SUM[i] = x[n[i]]+x[n[i]+1]+...+x[n[i]+l-1]

The goal is find contiguous and disjoint (non-overlapping) subsets S[1],S[2],... of lengths ranging from 1 to L that are as large as possible and cover all N elements of X.

For example, given X = {5,6,7,100,100,7,8,5,4,4} and L = 4, the solution is S[1] = {5,6,7}, S[2] = {100, 100, 7, 8}, and S[3] = {5,4,4} such that SUM[1] = 18, SUM[2] = 215, and SUM[3] = 13. While the overall sum, no matter the subsets, will always be 246, the key is that no other subsets with lengths ranging from 1 to L will produce larger SUM[i], than those provided above.

Any help is greatly appreciated.

score 0 · Answer 1 · edited May 23 '17 at 12:16

I'll clean up the code later, but here's the solution I came up with.

Sub getLargestEvents()

'Algorithm adapted from Maximizing the overall sum of K disjoint and contiguous subsets of size L among N positive numbers

Dim X As Variant
Dim N As Integer
Dim sumOfX As Integer
Dim L As Integer
Dim S As Variant
Dim subsetOfXforS As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim SUM As Variant
Dim sumOfM As Integer
Dim numberOfEvents As Integer
Dim M As Variant
Dim maxSUM As Integer
Dim maxI As Integer
Dim maxJ As Integer
Dim beginningSUM As Variant
Dim endingSUM As Variant

'X is the array of N losses (sorted) by day
X = Array(5, 6, 7, 100, 100, 7, 8, 5, 4, 4, 100, 100, 4, 5, 6, 7, 8)

'N is the number of days of loss in the array X
N = UBound(X)

For i = 0 To N
    sumOfX = sumOfX + X(i)
Next i

'L is the hours clause expressed in days (i.e., L = hours clause / 24)
L = 4

'S is the jagged array of N * ( L - 1 ) subsets of X containing no more than L contiguous days of loss
ReDim S(N, L - 1)

'subsetOfXforS is the array of L - 1 days of X containing j contiguous days of loss and is used to create the jagged array S
ReDim subsetOfXforS(L - 1)

For i = 0 To N
    For j = 0 To L - 1
        If i >= j Then
            For k = 0 To j
                Debug.Print X(i - j + k)
                subsetOfXforS(k) = X(i - j + k)
            Next k
        End If
        S(i, j) = subsetOfXforS
    Next j
Next i

'SUM is the array of summations of the members of S
ReDim SUM(N, L - 1)

For i = 0 To N
    For j = 0 To L - 1
        If i >= j Then
            For k = 0 To UBound(S(i, j))
                If j >= k Then
                    Debug.Print "S(" & i & ", "; j & ")(" & k & ") = " & S(i, j)(k)
                    SUM(i, j) = SUM(i, j) + S(i, j)(k)
                    Debug.Print "SUM(" & i & ", "; j & ") = " & SUM(i, j)
                End If
            Next k
        End If
    Next j
Next i

beginningSUM = SUM
ReDim M(N, 2)
endingSUM = SUM

Do While sumOfM < sumOfX

    maxSUM = 0

    'Determine max value in current array
    For i = 0 To N
        For j = 0 To L - 1
            If i >= j Then
                If beginningSUM(i, j) > maxSUM Then
                    maxSUM = SUM(i, j)
                    maxI = i
                    maxJ = j
                End If
                Debug.Print "beginningSUM(" & i & ", " & j & ") = " & beginningSUM(i, j)
            End If
        Next j
    Next i

    sumOfM = sumOfM + maxSUM
    'Store max value

    M(numberOfEvents, 0) = maxI
    M(numberOfEvents, 1) = maxJ
    M(numberOfEvents, 2) = maxSUM

    Debug.Print "maxI: " & maxI & ", maxJ: " & maxJ & ", maxSUM: " & maxSUM

    'Remove values that can no longer apply
    For i = 0 To N
        For j = 0 To L - 1
            If i >= j Then
                If (maxI - maxJ <= i And i <= maxI) Or (maxI < i And i - j <= maxI) Then
                    endingSUM(i, j) = 0
                    Debug.Print "endingSUM(" & i & ", " & j & ") = " & endingSUM(i, j) & " <- removed"
                Else
                    endingSUM(i, j) = beginningSUM(i, j)
                    Debug.Print "endingSUM(" & i & ", " & j & ") = " & endingSUM(i, j)
                End If
            End If
        Next j
    Next i

    beginningSUM = endingSUM
    numberOfEvents = numberOfEvents + 1
Loop

Debug.Print "Final Event Set"
For a = 0 To numberOfEvents - 1
        Debug.Print "i: " & M(a, 0) & ", j: " & M(a, 1) & ", M: " & M(a, 2)
Next a

End Sub

score 0 · Accepted Answer · answered Feb 28 '17 at 15:22

Here's a better solution:

 Sub getLargestEvents()

'Algorithm adapted from http://stackoverflow.com/questions/29268442/maximizing-the-overall-sum-of-k-disjoint-and-contiguous-subsets-of-size-l-among

    Dim N As Long 'limit of +2,147,483,647
    Dim X As Variant
    Dim i As Long
    Dim L As Integer
    Dim S As Variant
    Dim j As Integer
    Dim tempS As Variant
    Dim largestEvents As Variant
    Dim numberOfEvents As Long
    Dim sumOfM As Double
    Dim maxSUM As Double
    Dim maxI As Long
    Dim maxJ As Long

    X = Array(5, 6, 7, 100, 100, 7, 8, 5, 4, 4, 100, 100, 4, 5, 6, 7, 8)

   'N is the number of days of loss in the array X
    N = UBound(X)

    'L is the hours clause expressed in days (i.e., L = hours clause / 24)
    L = 4

   'S contains the sums of all events that contain no more than L contiguous days of loss
    ReDim S(L * N, L)

    'Debug.Print "i, j, S(i, j):"
    For i = 1 To N
        For j = 1 To L
            If i >= j Then
                S(i, j) = X(i) + S(i - 1, j - 1)
                'Debug.Print i & ", " & j & ", " & S(i, j)
            End If
        Next j
    Next i

    tempS = S
    ReDim largestEvents(N, 3)

    Do While WorksheetFunction.SUM(S) > 0

        maxSUM = 0
        numberOfEvents = numberOfEvents + 1

        'Determine max value in current array
        For i = 1 To N
            For j = 1 To L
                If i >= j Then
                    If tempS(i, j) > maxSUM Then 'tempS(i, j) > maxSUM Then
                        maxSUM = S(i, j)
                        maxI = i
                        maxJ = j
                    End If
                    'Debug.Print "tempS(" & i & ", " & j & ") = " & tempS(i, j)
                End If
            Next j
        Next i

        sumOfM = sumOfM + maxSUM
        'Store max value

        largestEvents(numberOfEvents, 1) = maxI
        largestEvents(numberOfEvents, 2) = maxJ
        largestEvents(numberOfEvents, 3) = maxSUM

        'Debug.Print "maxI: " & maxI & ", maxJ: " & maxJ & ", maxSUM: " & maxSUM

        'Remove values that can no longer apply
        For i = 1 To N
            For j = 1 To L
                If i >= j Then
                    If (maxI - maxJ < i And i <= maxI) Or (maxI < i And i - j < maxI) Then
                        tempS(i, j) = 0
                        'Debug.Print "tempS(" & i & ", " & j & ") = " & tempS(i, j) & " <- removed"
                    End If
                End If
            Next j
        Next i

        S = tempS

    Loop

    Debug.Print "Start Date, Length, Amount"

    For i = 1 To numberOfEvents
        Debug.Print "start date: " & largestEvents(i, 1) - largestEvents(i, 2) + 1 & ", length: " & largestEvents(i, 2) & ", amount: " & largestEvents(i, 3)
    Next i

End Sub

Function getUserSelectedRange(description As String) As Range
'Code adapted from
'http://stackoverflow.com/questions/22812235/using-vba-to-prompt-user-to-select-cells-possibly-on-different-sheet

    Set getUserSelectedRange = Application.InputBox("Select a range of " + description, "Obtain Range Object", Type:=8)

End Function

While this code may answer the question, providing additional context regarding why and/or how this code answers the question improves its long-term value. — Donald Duck, Feb 28 '17 at 15:40

Return the largest disjoint and contiguous subsets ranging from size 1 to L among N positive numbers

2 Answers2