Возвратите самые большие непересекающиеся и непрерывные подмножества от 1 до L среди N положительных чисел

Question

Я пытаюсь обобщить алгоритм Пол Ханкин, представленный в Maximizing the overall sum of K disjoint and contiguous subsets of size L among N positive numbers, так что решение не ограничено, чтобы каждое подмножество было точно размером L и где Цель состоит не в том, чтобы максимизировать общую сумму, а в том, чтобы вернуть множество с наибольшими возможными подмножествами.

изложив подробности, X представляет собой набор N положительных действительных чисел: X={x[1],x[2],...x[N]} where x[j]>=0 for all j=1,...,N.

Непрерывного подмножество называется S[i] состоит из доL последовательных членов X, начиная с позицией n[i] и заканчивающихся в положении 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.

Два таких подмножества S[i] и S[j] называются попарно непересекающимися (неперекрывающимися), если они не содержат одинаковых элементов X.

Определить суммирование членов каждой подгруппы:

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

Цель найти смежные и не пересекается (не перекрывающийся) подмножествами S[1],S[2],... длин в пределах от 1 to L, которые как можно больше и крышек все N элементы X.

Например, учитывая X = {5,6,7,100,100,7,8,5,4,4} и L = 4, решение S[1] = {5,6,7}, S[2] = {100, 100, 7, 8}, and S[3] = {5,4,4} таким образом, что SUM[1] = 18, SUM[2] = 215, and SUM[3] = 13. Хотя общая сумма, независимо от подмножества, всегда будет 246, ключ заключается в том, что никакие другие подмножества с длиной от 1 to L не будут производить больше SUM[i], чем те, которые указаны выше.

Любая помощь очень ценится.

Answer 1

Вот лучшее решение:

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 

Answer 2

Я очищу код позже, но вот решение, которое я придумал.

Sub getLargestEvents()

«Алгоритм адаптировано из 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