Re: combinatorics problem
- To: mathgroup at smc.vnet.net
- Subject: [mg40104] Re: [mg40087] combinatorics problem
- From: Dr Bob <drbob at bigfoot.com>
- Date: Thu, 20 Mar 2003 03:34:52 -0500 (EST)
- References: <200303190823.DAA28940@smc.vnet.net>
- Reply-to: drbob at bigfoot.com
- Sender: owner-wri-mathgroup at wolfram.com
This gets you a step or two farther:
<< DiscreteMath`Combinatorica`;
ClearAll[combinations];
combinations::usage = "combinations[list,n:{__Integer}] lists the \
combinations of list taken n at a time";
combinations[r_List, n_Integer, {}] := Which[n > Length@r, {}, n ==
Length@r, \
r, True, DiscreteMath`Combinatorica`KSubsets[r, n]];
combinations[r_List, n_Integer, e_?VectorQ] := Join[e, #] & /@ \
DiscreteMath`Combinatorica`KSubsets[Complement[r, e], n];
combinations[r_List, n_Integer, e : {__?VectorQ}] := Flatten[combinations[
r, n, #] & /@ e, 1];
combinations[r_List, {n_Integer}] := combinations[r, n, {}];
combinations[r_List, n : {__Integer}] := Which[Plus @@ n == Length@r,
Join[#, Complement[r, #]] & /@ combinations[r, Drop[
n, -1]], Plus @@ n > Length@r, {}, True, Fold[combinations[r, #2,
#1] &, {}, n]]
ClearAll@splitter
splitter[n : {__Integer}] := Range @@@ Transpose@{Drop[FoldList[Plus, 1,
p], -1], Rest@FoldList[Plus, 0, p]}
combo[a_List, n : {__Integer}] :=
Transpose[combinations[a, n][[All, #]] & /@ splitter@n]
listA = {1, 2, 3, 4, 5};
p = {2, 2, 1};
combo[listA, p]
Bobby
On Wed, 19 Mar 2003 03:23:24 -0500 (EST), Szumiloski, John
<john_szumiloski at merck.com> wrote:
> Dear MathGroupers,
>
> (I use both v4.2 for WinNT 4 w/ 512MB RAM, and v4.0.1 for MacOS 8.6 w/
> 160
> MB RAM.)
>
> I am trying to write a function which takes a list 'listA' of n integers
> (perhaps nondistinct) and an arbitrary integer partition 'P' of n, and,
> for
> the list of all the ways to partition the elements of listA into sublists
> of
> the sizes given by P, sums each sublist for each instance and returns the
> number of times each distinct set of sums (where the order is not
> important)
> occurs. (Apologies for using 'partition' in two different ways here)
>
> This is complicated, so an example definitely helps. Let's break the
> problem up. Say the function prelimfunc returns a list of all the ways
> to
> partition the elements of listA into sublists of the sizes given by P:
>
> In[1]:= listA = {1,2,3,4,5} ; P = {2,2,1}; (* Note Length[listA] =
> Apply[Plus,P] *)
>
> In[2]:= pre1=prelimfunc[listA, P] Out[2]= { {{1,2},{3,4},{5}},
> {{1,2},{3,5},{4}}, {{1,2},{4,5},{3}}, {{1,3},{2,4},{5}},
> {{1,3},{2,5},{4}}, {{1,3},{4,5},{2}}, {{1,4},{2,3},{5}},
> {{1,4},{2,5},{3}}, {{1,4},{3,5},{2}}, {{1,5},{2,3},{4}},
> {{1,5},{2,4},{3}}, {{1,5},{3,4},{2}}, {{2,3},{4,5},{1}},
> {{2,4},{3,5},{1}}, {{2,5},{3,4},{1}} }
>
> Desired properties of prelimfunc:
> 1) The order of the returned list is not important; the example's order
> was
> just an artifact of my enumerating the result in my head.
> 2) The ordering of the sublists are not important. Thus,
> {{1,2},{3,4},{5}}
> would be considered the same list as {{3,4},{1,2},{5}}, so only one would
> appear in the result. 3) The ordering of the elements within each
> sublist are not important.
> Thus, {{1,2},{3,4},{5}} would be considered the same list as
> {{2,1},{3,4},{5}}, so only one would appear in the result. 4) Replicates
> of the elements of listA are considered distinct. This, if
> listA={1,2,3,1,5} (where there are two elements equal to 1), there would
> be
> two lists of {{1,3},{1,5},{2}} in the result, corresponding to the 6th
> and
> 12th list element in the above output. Since there are two "1"s in this
> listA, this result would not violate property (2) above, since the "1"s
> are
> considered distinct. Thus the result will always contain the same number
> of
> possible partitions of listA so long as listA has same length n and the
> integer partition of n remains the same.
>
> The next operation would be, for each element in this list, to sum up
> each
> sublist:
>
> In[3]:= pre2=Map[Apply[Plus, #]&, pre1, {2}]
> Out[3]= { {3, 7, 5}, {3, 8, 4}, {3, 9, 3}, {4, 6, 5}, {4, 7, 4}, {4, 9,
> 2}, {5, 5, 5}, {5, 7, 3}, {5, 8, 2}, {6, 5, 4}, {6, 6, 3}, {6, 7, 2}, {5,
> 9, 1}, {6, 8, 1}, {7, 7, 1} }
>
> Next, determine the distinct set of sums:
>
> In[4]:= pre3=Union[Map[Sort, pre2] ]
> Out[4]= { {1, 5, 9}, {1, 6, 8}, {1, 7, 7}, {2, 4, 9}, {2, 5, 8}, {2, 6,
> 7}, {3, 3, 9}, {3, 4, 8}, {3, 5, 7}, {3, 6, 6}, {4, 4, 7}, {4, 5, 6}, {5,
> 5, 5} }
>
> Next, for each of these sets, count how many times each appears in the
> previous result (order not being important):
>
> In[5]:= pre4=Map[Count[#, True]&, Outer[SameQ, pre3, Map[Sort, pre2], 1]
> ]
> Out[5]= {1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1, 2, 1}
>
> Last, return the unique sets of sums with the number of times each
> appears:
>
> In[6]:= Thread[List[pre3, pre4] ] (* for example *)
> Out[6]= { {{1, 5, 9}, 1}, {{1, 6, 8}, 1}, {{1, 7, 7}, 1}, {{2, 4, 9}, 1},
> {{2, 5, 8}, 1}, {{2, 6, 7}, 1}, {{3, 3, 9}, 1}, {{3, 4, 8},
> 1},
> {{3, 5, 7}, 2}, {{3, 6, 6}, 1}, {{4, 4, 7}, 1}, {{4, 5, 6},
> 2}, {{5, 5, 5}, 1} }
>
> So I want a function myfunc which would do this:
>
> In[7]:= myfunc[listA, P]
> Out[7]= { {{1, 5, 9}, 1}, {{1, 6, 8}, 1}, {{1, 7, 7}, 1}, {{2, 4, 9}, 1},
> {{2, 5, 8}, 1}, {{2, 6, 7}, 1}, {{3, 3, 9}, 1}, {{3, 4, 8},
> 1},
> {{3, 5, 7}, 2}, {{3, 6, 6}, 1}, {{4, 4, 7}, 1}, {{4, 5, 6},
> 2}, {{5, 5, 5}, 1} }
>
> Another example, with more multiplicities:
>
> In[8]:= myfunc[{1,1,2,2,3}, {2,2,1}]
> Out[8]= { {{1, 3, 5}, 4}, {{1, 4, 4}, 2}, {{2, 2, 5}, 2},
> {{2, 3, 4}, 5}, {{3, 3, 3}, 2} }
>
> I have figured out how to write a naive version of prelimfunc by 1)
> simply
> enumerating all permutations of listA, 2) pruning (if P has some repeated
> elements; accounts for property (2) above), 3) inserting braces in the
> appropriate places. So with the additional steps above given explicitly,
> in
> a sense I have solved my problem.
>
>
> ****However****, I would like a solution which does not have intermediate
> steps that consume memory (and time?) at an (supra-?)exponential rate. I
> am
> interested in using listA of 30-40 elements or maybe more (!).
>
> One approach could be to enumerate the distinct set of sums (e.g., pre3)
> first, then determine how many times each would appear. I have written
> this
> function which enumerates the possible sum sets, based loosely on the
> Partitions code in the Combinatorica package:
>
> (******** Begin code ********)
> NonZeroCompositions[totalsum_Integer /; totalsum <= 1, ___] := {};
> NonZeroCompositions[totalsum_Integer, ngroups_Integer /; ngroups < 1,
> ___]
> := {};
> NonZeroCompositions[totalsum_Integer, 1, ___ ] := {{totalsum}};
> NonZeroCompositions[totalsum_Integer, ngroups_Integer, ___] /; (ngroups >
> totalsum) := {};
> NonZeroCompositions[totalsum_Integer, ngroups_Integer] :=
> NonZeroCompositions[totalsum, ngroups] = NonZeroCompositions[totalsum,
> ngroups, 1];
> NonZeroCompositions[totalsum_Integer, ngroups_Integer, low_Integer] /;
> (low * ngroups > totalsum)
> := {};
> (* ...and the workhorse... *)
> NonZeroCompositions[totalsum_Integer, ngroups_Integer, low_Integer] :=
> Partition[Flatten[Table[Map[Append[{i}, #] &,
> NonZeroCompositions[totalsum -
> i, ngroups - 1, i]],
> {i, low, Floor[totalsum/ngroups]}
> ]
> ], ngroups];
> (******** End code ********)
>
> The argument totalsum refers to the sum of the elements of listA (so the
> sum
> over each set in the result is also this), and ngroups to the number of
> elements in the partition P. Thus to get the candidate sum sets for the
> example, we do
>
> In[8]:= sets=NonZeroCompositions[Apply[Plus, listA] (* = 15 *), Length[P]
> (*
> = 3 *) ]
> Out[8]= { {1, 1, 13}, {1, 2, 12}, {1, 3, 11}, {1, 4, 10}, {1, 5, 9}, {1,
> 6,
> 8}, {1, 7, 7}, {2, 2, 11}, {2, 3, 10}, {2, 4, 9}, {2, 5, 8}, {2,
> 6, 7}, {3, 3, 9}, {3, 4, 8}, {3, 5, 7}, {3, 6, 6}, {4, 4, 7}, {4, 5,
> 6}, {5, 5, 5} }
>
> Now some of these do not appear in pre3 (e.g., {1,1,13}); without loss of
> generality I would have my function not include such sum sets in the
> final
> result.
>
>
> Given 'listA', 'P', and now 'sets', I suspect I can Map 'sets' into a
> function of listA and P which counts the number of times each sum set
> would
> appear, **without** actually enumerating all the partitions, summing
> etc.,
> etc. I strongly suspect this can be done using Backtrack from the
> Combinatorica package. But this is now getting beyond my level of
> Mathematica competence.
>
> Any assistance would be most welcome; suggestions of course do not have
> to
> utilize my NonZeroCompositions function, although I suspect it would be
> useful. If I get more than one approach, I may summarize some
> performance
> benchmarks for the group.
>
> Thanks in advance for any insights.
>
> John
>
> --------------------------------------------------------------------------
>
>
> ----
> Notice: This e-mail message, together with any attachments, contains
> information of Merck & Co., Inc. (Whitehouse Station, New Jersey, USA)
> that may be confidential, proprietary copyrighted and/or legally
> privileged, and is intended solely for the use of the individual or
> entity named on this message. If you are not the intended recipient, and
> have received this message in error, please immediately return this by e-
> mail and then delete it.
>
> ==============================================================================
>
>
>
--
majort at cox-internet.com
Bobby R. Treat
- References:
- combinatorics problem
- From: "Szumiloski, John" <john_szumiloski@merck.com>
- combinatorics problem