3
$\begingroup$

Let's say I have a list L containing n numerical numbers. Now I want to find all sub-sets of m < n different elements out of L such that at least one combination of summing or subtracting those m elements with each other gives zero to numerical precision. Is it possible to do that in Mathematica in a convenient way? Thanks for any suggestion!

$\endgroup$
  • $\begingroup$ With a looping construct, the subtraction portion is could be implemented using Differences. As the documentation for it notes, Differences can be equivalently implemented using ListConvolve so you may be able to use that to implement the summing portion. $\endgroup$ – IPoiler Jul 28 '15 at 16:17
  • $\begingroup$ What do you mean by "summing or subtracting those m elements"? If it's the whole list, I'm not sure what you mean by "subtract". Summing makes sense, though. $\endgroup$ – march Jul 28 '15 at 18:06
  • $\begingroup$ I mean taking the m numbers, attaching all possible phase combinations of plus or minus to each one and then summing them (which yields a single scalar in each case) to see if any one of these summations gives zero. $\endgroup$ – Kagaratsch Jul 28 '15 at 19:02
  • $\begingroup$ Could set it up as an integer linear programming problem. Coefficients must all be in the set {-1,0,1}. If you insist that m be nonzero then the sum of absolute values of the coeffs must be m. A slightly complicated setup but not unreasonably difficult to code. $\endgroup$ – Daniel Lichtblau Jul 29 '15 at 2:02
  • $\begingroup$ @DanielLichtblau. I would be interested in seeing that solution, if you've got the time, since I imagine it will be much faster than mine. $\endgroup$ – march Jul 29 '15 at 3:39
4
$\begingroup$

Solution

Suppose the list is

list = Range[-3, 3]
(* {-3, -2, -1, 0, 1, 2, -3} *)

Then, the set of all subsets of, say, size 3 is

sets = Subsets[list, {3}];

We define a list of signs that give all possible combinations of plusses and minuses to attach to each subset:

signs = Tuples[{-1, 1}, 3]
(* {{-1, -1, -1}, {-1, -1, 1}, {-1, 1, -1}, {-1, 1, 1}
    , {1, -1, -1}, {1, -1, 1}, {1, 1, -1}, {1, 1, 1}} *)

Then, we want to select from the list sets the subsets that will be zero when dotted with at least one of the elements of signs. To make this happen, we will use Select, which takes as a second argument an expression that will accept an element a of sets as an input and output True if a Dotted with one of the elements of sign is zero and False otherwise. Select then keeps the ones that evaluate to True. The expression

Select[sets, (Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) &]

results in

(* {{-3, -2, -1}, {-3, -2, 1}, {-3, -1, 2}, {-3, 0, 3}
    , {-3, 1, 2}, {-2, -1, 1}, {-2, -1, 3}, {-2, 0, 2}
    , {-2, 1, 3}, {-1, 0, 1}, {-1, 1, 2}, {-1, 2, 3}, {1, 2, 3}}  *)

Explanation

Let's pick the condition function apart. First,

Function[{x}, 0 == Dot[a, x]]

is a function that accepts an input x (which will be from signs), Dots it with a (which will be an element of sets) and compares it to 0, yielding True if it is equal to 0. For instance,

Function[{x}, 0 == Dot[{-1, 0, 1}, x]][{1, -1, 1}]

will yield True while

Function[{x}, 0 == Dot[{-1, 0, 1}, x]][{-1, -1, 1}]

will yield False. Then, for a particular a from sets, we Map this function over signs to yield all the possible comparisons:

Function[{x}, 0 == Dot[{-1, 0, 1}, x]] /@ signs
(* {True, False, True, False, False, True, False, True} *)

Finally, we Apply Or to this list to see if it at least one of the elements is True:

Or @@ Function[{x}, 0 == Dot[{-1, 0, 1}, x]] /@ signs
(* True *)

Finally, in order to make this work as the second argument of Select, we have to turn it into a function that will accept an element of sets as an input. Thus:

(Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) &

This turns the expression into a pure function whose input goes where the # is. For instance, we can see that

(Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) & [{-1, 0, 1}]

is the same as what we just did in parts above. Since Select will go one-by-one through the list sets, we get to just call

Select[sets, (Or @@ Function[{x}, 0 == Dot[#, x]] /@ signs) &]

Automate over all subset lengths

Finally, we can do this for every subset length (although, of course, this problem grows really fast, so user beware) as follows. We will do, as an example,

list = Range[-2, 2]
(* {-2, -1, 0, 1, 2} *)

Then,

Table[
 Select[
  Subsets[list, {m}]
  , (Or @@ Function[{x}, 0 == Dot[#, x]] /@ Tuples[{-1, 1}, {m}]) &
 ]
, {m, 1, Length@list}]

yielding

{
 {{0}}
 , {{-2, 2}, {-1, 1}}
 , {{-2, -1, 1}, {-2, 0, 2}, {-1, 0, 1}, {-1, 1, 2}}
 , {{-2, -1, 0, 1}, {-2, -1, 1, 2}, {-1, 0, 1, 2}}
 , {{-2, -1, 0, 1, 2}}
}
|improve this answer|||||
$\endgroup$
  • $\begingroup$ I did not understand your last line of code, so I wrote my own: result = {}; Do[If[! FreeQ[ Table[signs[[i]].sets[[j]], {i, 1, Dimensions[signs][[1]]}] // Chop, 0], result = Append[result, sets[[j]]];], {j, 1, Dimensions[sets][[1]]}]. However, my code seems to find way fewer results when the range gets bigger, and I am not sure what is going on. $\endgroup$ – Kagaratsch Jul 28 '15 at 19:41
  • 1
    $\begingroup$ @Kagaratsch. I have an updated (and significantly changed) version that seems to match yours. I haven't done any speed checking, so I don't know which version is faster. I have included an explanation as to how it works. I have also generalized to get all the subsets of any length. $\endgroup$ – march Jul 28 '15 at 20:47
4
$\begingroup$

I'm not thrilled with the question since it provided no example, but there was a serious response and also a request to see an ILP approach. Here is one such.

Start by creating an example.

SeedRandom[1111];
n = 10;
m = 4;
intset = RandomInteger[100, n]

(* Out[335]= {9, 78, 23, 59, 95, 51, 24, 29, 99, 68} *)

Now we set up the ILP. We have our n -1/0/1 variables as multipliers of the set elements, and variables denoting absolute values thereof (so must be greater-equal to the corresponding multipliers and their negatives). These absolute value variables must sum to m. To enforce that the absolute variables are never strictly larger than corresponding multipliers we use another pair of 0-1 variables, with sum not exceeding 1 for each pair. These get used in pairs of equations for each multiplier/absolute value pair. Details are left to the code below.

cvars = Array[c, n];
abscvars = Array[ac, n];
uvars = Array[u, n];
vvars = Array[v, n];
allvars = Join[cvars, abscvars, uvars, vvars];
c1 = Map[-1 <= # <= 1 &, cvars];
c2 = Map[0 <= # <= 1 &, abscvars];
c3 = MapThread[{#2 >= #1, #2 >= -#1} &, {cvars, abscvars}];
c4 = Total[abscvars] == m;
c5 = cvars.intset == 0;
c6 = Map[0 <= # <= 1 &, Join[uvars, vvars]];
c7 = MapThread[#1 + #2 <= 1 &, {uvars, vvars}];
c8 = MapThread[{#1 + #2 - 2*#3 == 0, #1 - #2 - 2*#4 == 
      0} &, {abscvars, cvars, uvars, vvars}];
constraints = 
  Flatten[{c1, c2, c3, c4, c5, c6, c7, c8, 
    Element[allvars, Integers]}];

Here we solve it and reform as subsets with negatives where indicated. I probably should have added some constraint to remove trivial duplicates (wherein one solution is the negative of another).

Map[intset*# &, (cvars /. Solve[constraints, allvars])] /. 
 0 :> Sequence[]

(* Out[350]= {{-78, 95, 51, -68}, {-95, 51, -24, 68}, {95, -51, 
  24, -68}, {78, -95, -51, 68}} *)

Here is a substantially larger example.

SeedRandom[1111];
n = 20;
m = 8;
intset = RandomInteger[1000, n]

(* Out[354]= {79, 679, 93, 887, 870, 398, 413, 796, 273, 288, 947, 708,
232, 488, 464, 760, 458, 482, 174, 502} *)

cvars = Array[c, n];
abscvars = Array[ac, n];
uvars = Array[u, n];
vvars = Array[v, n];
allvars = Join[cvars, abscvars, uvars, vvars];
c1 = Map[-1 <= # <= 1 &, cvars];
c2 = Map[0 <= # <= 1 &, abscvars];
c3 = MapThread[{#2 >= #1, #2 >= -#1} &, {cvars, abscvars}];
c4 = Total[abscvars] == m;
c5 = cvars.intset == 0;
c6 = Map[0 <= # <= 1 &, Join[uvars, vvars]];
c7 = MapThread[#1 + #2 <= 1 &, {uvars, vvars}];
c8 = MapThread[{#1 + #2 - 2*#3 == 0, #1 - #2 - 2*#4 == 
      0} &, {abscvars, cvars, uvars, vvars}];
constraints = 
  Flatten[{c1, c2, c3, c4, c5, c6, c7, c8, 
    Element[allvars, Integers]}];

Timing[subsets = 
   Map[intset*# &, (cvars /. Solve[constraints, allvars])] /. 
    0 :> Sequence[];]

Length[subsets]

(* Out[370]= {76.94338, Null}

Out[371]= 7952 *)

Here are the first few.

subsets[[1 ;; 5]]

(* {{-79, -679, -93, -887, 708, -232, 760, 
  502}, {-79, -679, -93, -887, 288, 232, 760, 
  458}, {-79, -679, -93, -887, 398, 708, 458, 
  174}, {-79, -679, -93, -870, -398, 947, 708, 
  464}, {-79, -679, -93, -870, 947, -488, 760, 502}} *)

At small risk for correctness this could be made faster by writing an explicit branch-and-prune loop, using approximate linear programming on the relaxed problems (built-in Solve code uses exact linear programming on those). Some idea of how such a loop might be done can be found here.

|improve this answer|||||
$\endgroup$
  • $\begingroup$ Thanks (belatedly) for the answer! I like to use answers here to learn both Mathematica-specific methods and general programming methods. $\endgroup$ – march Aug 6 '15 at 0:50

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.