Re: Using a list as a variable
- To: mathgroup at smc.vnet.net
- Subject: [mg67143] Re: [mg67069] Using a list as a variable
- From: Andrzej Kozlowski <akoz at mimuw.edu.pl>
- Date: Sat, 10 Jun 2006 04:54:01 -0400 (EDT)
- References: <200606080854.EAA12414@smc.vnet.net> <503E620F-D55A-41A7-8892-4795AB905053@mimuw.edu.pl> <003001c68b16$a63943f0$6501a8c0@bblaptop> <E1CFD0D4-97B2-4132-AA83-84A8EB4C9839@mimuw.edu.pl>
- Sender: owner-wri-mathgroup at wolfram.com
On 9 Jun 2006, at 22:16, Andrzej Kozlowski wrote:
>
> On 9 Jun 2006, at 01:14, Bonny Banerjee wrote:
>
>>>
>>>
>>> On 8 Jun 2006, at 17:54, Bonny Banerjee wrote:
>>>
>>>> I would like to use a list (or set) as a variable. I am working
>>>> on the
>>>> Subset-Sum problem. Given a set S of integers, the goal is to
>>>> find a subset
>>>> of S (say Q) whose elements add to a given integer x. This is
>>>> how I would
>>>> like to define the function:
>>>>
>>>> SubsetSum(S, x) := {Q such that Q is a subset of S and sum of
>>>> the elements
>>>> of Q is x}
>>>>
>>>> In Mathematica functional programming language, this would look
>>>> like:
>>>>
>>>> SubsetSum[S_, x_] := Reduce[Q \[Element] Subsets[S] && Sum[Q,
>>>> {i,1,Length[Q]}]==x, Q, Reals]
>>>>
>>>> Now when I try to evaluate SubsetSum[{1, 3, 5, 2, 7, 100, 6},
>>>> 101], the
>>>> output is as follows:
>>>>
>>>> Reduce : : naqs :
>>>> \[Exists]{Q} Q is not a quantified system of equations and
>>>> inequalities. More ...
>>>>
>>>> Out[365]= Reduce[Q, False, Q, Reals]
>>>>
>>>>
>>>> I guess, Mathematica is not being able to understand from my
>>>> statement that
>>>> the variable Q is not an atom but a list. But it should since I
>>>> stated that
>>>> Q is an element of the power set of S.
>>>>
>>>> Note that I know how to write a function for Subset-Sum using a
>>>> Module. But
>>>> I am interested in functional programming, similar to the format
>>>> shown
>>>> above.
>>>>
>>>> Any help would be appreciated.
>>>>
>>>> Thanks much,
>>>> Bonny.
>>>>
>>>>
>>>
>>>
>>> Reduce solves (or "reduces" ) algebraic and some transcendental
>>> (e.g. trygonometric) equations and inequalities. Your problem is
>>> not of this kind.
>>>
>>> One way to solve it:
>>>
>>> SubsetSum[S_, x_] := Select[Subsets[S], Total[#] == x &]
>>>
>>>
>>> SubsetSum[{1, 3, 5, 2, 7, 100, 6}, 101]
>>>
>>>
>>> {{1, 100}}
>>>
>>>
>>> SubsetSum[{1, 3, 5, 2, 7, 100, 6}, 105]
>>>
>>>
>>> {{5, 100}, {3, 2, 100}}
>>>
>>>
>>> Andrzej Kozlowski
>>> Tokyo, Japan
>>>
>>
>> That was very helpful. Thanks.
>>
>> Now I would like to create a similar function for grouping a set
>> of elements, say S, into n groups so that union of all those
>> groups is S, intersection of any two groups is {}, and sum of
>> variance of each group is minimized. Note that in SubsetSum, it
>> was required to select a subset of S and check whether it elements
>> add to x or not. So we could do Select[Subsets[S], ...].
>>
>> In grouping, it is required to select a set of subsets of S, and
>> check whether their union is S and mutual intersection is {} and
>> variance is minimized or not. So we need to do Select[Subsets
>> [Subsets[S]], ...]. But that is going to be computationally very
>> intensive as it will search in a space of O(2^(2^m)) elements
>> where m is the number of elements in S.
>>
>> Is there a more computationally efficient method possible using
>> the approach similar to SubsetSum?
>>
>> Thanks once again for your help.
>> Bonny.
>
> Hm... I am not quite sure if I understand you correctly. Obviously
> you must be disallowing partitions into single element sets, since
> the variance of such a singleton is zero so the splitting of a set
> into disjoint singletons would always have the sum of variances
> zero. So presumably you require your "groups" to have at least two
> elements each?
> If my assumption is correct, a simple-minded solution of your
> problem could look as this. First we simply make a list of all
> partitions of your set S. The function SetPartitions from the
> Combinatorica package could be used for that. Then we remove all
> partitions containing a set with one element. This is also easy.
> Finally we simply find the partition with the smallest sum of
> variances. Here is a simple implementation.
>
> << Discretemath`Combinatorica`
>
> VarianceOrderedPartitions1[s_?(VectorQ[#, NumericQ] &)] :=
> With[{p = DeleteCases[SetPartitions[s], {___, l_, ___} /;
> Length[l] == 1], f = Total[Variance /@ #] &}, p[[Ordering[f /@ p]]]]
>
>
> Let's try it on a simple example:
>
> pts=VarianceOrderedPartitions1[{2, 3, 5, 7}]
>
>
> {{{2, 3}, {5, 7}}, {{2, 3, 5, 7}}, {{2, 5}, {3, 7}}, {{2, 7}, {3, 5}}}
>
> The actual sums of variances are:
>
> Total[Variance/@#]&/@pts//N
>
>
> {2.5,4.91667,12.5,14.5}
>
>
> Of course this program is dreadfully slow. We can try to improve it
> in various ways, by using backtracking for example, etc. But I
> think the largest improvement will be made by observing that find
> the partition with the smallest sum of variances we do not actually
> need to consider all partitions into subsets but partitions into
> subsets which have the property that for any two subsets all the
> elements in one subset are either smaller or larger than all the
> elements in the other subset. This makes it possible to write a
> much more efficient program. It also makes use of the Combinatorica
> package, but this time of the function Partitions[n], which gives
> all the partitions of an integer n. I did not try to make it
> particularly functional or efficient, but it still beats the first
> one by a huge margin.
>
>
> VarianceOrderedPartitions2[SS_?(VectorQ[#, NumericQ] &)] := Module
> [{n =
> Length[SS], f,
> v, ord}, f[l_] := With[{s = FoldList[Plus, 0, l]}, Transpose
> [{Most[s +
> 1], Rest[s]}]];
> v = Map[Take[Sort[SS], #] &,
> Map[f, Flatten[Permutations /@ DeleteCases[
> Partitions[n], {___,
> 1, ___}], 1]], {2}]; v[[Ordering[Map[Total[Variance /@ #]
> &, v]]]]]
>
>
> Let's compare the performance on a random sample. I will use only
> 10 sample points as the function VarianceOrderedPartitions1 is too
> slow for many more:
>
>
> SS=Table[Random[Integer,{1,50}],{10}]
>
>
> {3,35,27,36,43,15,43,18,49,17}
>
> Let's try the first function, which considers all the possible
> partitions:
>
>
> Take[VarianceOrderedPartitions1[SS],2]//Timing
>
>
> {10.169279*Second, {{{3, 15, 18, 17}, {35, 27, 36}, {43, 43, 49}},
> {{3, 27, 15, 18, 17}, {35, 36}, {43, 43, 49}}}}
>
> Now let's try to do it with the other:
>
>
> Timing[Take[VarianceOrderedPartitions2[SS], 2]]
>
>
> {0.015622000000000469*Second, {{{3, 15, 17, 18}, {27, 35, 36}, {43,
> 43, 49}}, {{3, 15, 17, 18, 27}, {35, 36}, {43, 43, 49}}}}
>
> The answers are the same (except that the second function sorts the
> numbers so the answer looks a bit different) but the difference in
> the time taken is quite impressive. The winning partition {{3, 15,
> 17, 18}, {27, 35, 36}, {43, 43, 49}} has the sum of variances
>
>
> Total[Variance/@#]&@{{3,15,17,18},{27,35,36},{43,43,49}}//N
>
>
> 84.5833
>
> while the original set has variance
>
>
> Variance[SS]//N
>
>
> 224.044
>
> Andrzej Kozlowski
> Tokyo, Japan
Having read your message again I now think that I possibly
misunderstood you, and what you wanted was to partition a set of
numbers into a fixed number of disjoint subsets so that the total sum
of variances will be minimal. In that one element sets should be
allowed and we have to redefine Mathematica's Variance function,
since it only works with lists of numbers with more than one element.
The following modification of VariancePartitions2 will do this:
<<Discretemath`Combinatorica`
Unprotect[Variance];
Variance[{x_}]:=0;
Protect[Variance];
VarianceOrderedPartitions3[SS_?(VectorQ[#, NumericQ] &), k_] := Module
[{n =
Length[SS], f,
v, ord}, f[l_] := With[{s = FoldList[Plus, 0, l]}, Transpose[{Most
[s +
1], Rest[s]}]];
v = Map[Take[Sort[SS], #] &,
Map[f, Flatten[Permutations /@ Select[
Partitions[n], Length[#] == k &], 1]], {2}]; v[[
Ordering[Map[Total[Variance /@ #] &, v]]]]]
Now, let's again generate a random set:
SS=Table[Random[Integer,{1,50}],{10}]
{44,30,17,3,29,29,42,49,45,47}
The variance of this set is:
Variance[SS]//N
221.389
Let's try to find the partitions into 5 sets with minimum variance.
ls = VarianceOrderedPartitions3[SS, 5];
The full list of sums of variances of the partitions in ls (these are
not all possible partitions, but the minimal partitions are always
included in this list) is :
Total[Variance/@#]&/@ls//N
{4.66667,4.66667,5.25,6.33333,7.3,7.8,40.5833,40.5833,40.75,42.25,42.25,
42.25,\
42.6667,42.8333,44.3333,45.3,45.3667,50.25,52.3333,52.3333,52.9167,54.,5
7.25,\
58.7,58.7,61.3333,62.7,62.7,63.5,65.5833,76.8333,76.8333,76.9167,77.4167
,78.5,\
78.8,79.3,80.3,80.3,96.25,98.1667,100.667,100.667,100.833,102.333,102.33
3,102.\
333,102.333,102.333,102.833,102.833,102.917,103.417,104.,104.5,105.3,107
.333,\
107.333,117.3,122.25,122.333,122.5,124.,126.667,126.833,128.333,133.333,
133.5,\
135.583,135.583,137.3,138.8,138.8,138.8,138.833,140.333,140.333,143.3,14
6.25,\
148.25,148.917,152.667,152.833,154.333,154.7,155.333,155.333,155.5,157.,
157.,\
157.,157.333,157.333,159.333,159.5,161.583,161.583,172.167,172.167,172.3
33,\
172.333,172.5,173.667,173.667,173.833,173.833,173.833,174.,174.25,174.91
7,175.\
333,178.8,210.333,217.583,222.167,223.667,223.667,225.5,227.,227.,228.66
7,228.\
667,230.917,243.667,243.833,245.333}
There are two winners:
Take[ls, 2]
{{{3}, {17}, {29, 29, 30}, {42, 44, 45, 47}, {49}}, {{3}, {17}, {29,
29, 30}, {42, 44, 45}, {47, 49}}}
The performance of this program could still be much improved by, for
example, using backtracking, but I can't spend anymore time on this.
Andrzej Kozlowski
- References:
- Using a list as a variable
- From: "Bonny Banerjee" <banerjee@cse.ohio-state.edu>
- Using a list as a variable