1
$\begingroup$

Let A and M sets of numbers, with Length[A]=15. I want to do something like

Pick[M, #+A[[1]] <= 1 & /@ M]

but, instead of testing only with $i=1$, testing with all $i\in\{1,...,15\}$. I can use Pick again and again (15 times in total) to achieve the result I want, but this is not a good idea. What can I do?

EDIT1: This is an example. Let $M=\{0,1,2,3,4,5\}$ and $A=\{-1,-2,-3,..., -15\}$. I want to get the subset $M'$ of $M$ formed by the elements $x\in M$ such that $x+y\leq 1$ for all $y\in A$, that is, $$M'= \{0,1,2\}.$$

The code have to work with any condition rather than summation, that is, it has to work with product for real number or the inner product for vectors, and so on. The problem here is that #+A[[i]] test the condition "$\leq 1$" with only one element of A (the $i$-nth), and I want to test with all of them.

EDIT2: This is my true motivation. Let

M={{0, 0, 0, 1}, {-(1/2), -(1/2), 1/2, 1/2}, {-(1/2), -(1/2), -(1/2), 1/2}, {-(1/2), 1/2, 1/2, 1/2}, {1/2, 1/2, 1/2, 1/2}, {-(1/2), 1/2, -(1/2), 1/2}, {1/2, -(1/2), 1/2, 1/2}, {-1, 0, 0, 0}, {0, 0, 1,0}, {1/2, -(1/2), -(1/2), 1/2}, {1/2, 1/2, -(1/2), 1/2}, {0, -1, 0, 0}, {0, 1, 0, 0}, {0, 0, -1, 0}, {1, 0, 0, 0}, {-(1/2), -(1/2), -(1/2), -(1/2)}, {-(1/2), -(1/2), 1/2, -(1/2)}, {-(1/2), 1/2, 1/2, -(1/2)}, {1/2, 1/2, 1/2, -(1/2)}, {-(1/2), 1/2, -(1/2), -(1/2)}, {1/2, -(1/2), 1/2, -(1/2)}, {1/2, -(1/2), -(1/2), -(1/2)}, {1/2, 1/2, -(1/2), -(1/2)}, {0, 0, 0, -1}}

and

A={{1, 1, 1, 1}, {1, -1, 1, -1}, {-1, 1, -1, 1}, {-1, -1, -1, -1}, {1, 1, -1, -1}, {1, -1, -1, 1}, {-1, 1, 1, -1}, {-1, -1, 1, 1}}.

I aim to obtain as output the subset $$M'=\{v\in M~;~|\langle v,w \rangle|\leq 1, \forall~ w\in A\}.$$ With Pick[M, Abs[#.A[[1]]] <= 1 & /@ M] I get the set $$M'_0=\{v\in M~;~|\langle v,w_1 \rangle|\leq 1\},$$ where w1=A[[1]]. I could use Pick again like

Pick[Pick[M, #+A[[1]] <= 1 & /@ M],#+A[[2]] <= 1 & /@Pick[M, #+A[[1]] <= 1 & /@ M]]

and get $$M'_1=M'_0\cap\{v\in M~;~|\langle v,w_2 \rangle|\leq 1\},$$ where w2=A[[2]]. I am looking for a smarter way to obtain $M'$.

I just realize that using Table[Select[M, # + A[[k]] <= 1 &], {k, Length[A]}] and then Flatten and then DeleteDuplicates is not a solution. As above, we have to make intersections, and this is an union.

$\endgroup$
  • $\begingroup$ Why it's not a good idea? You can calculate selectors in one go and map over them with Pick[M, #] & /@ Outer[#1 + #2 <= 1 &, M, A] $\endgroup$ – swish Oct 2 '17 at 0:20
  • $\begingroup$ What I said is not a good idea is use something like Pick[Pick[M, #+A[[1]] <= 1 & /@ M],#+A[[2]] <= 1 & /@Pick[M, #+A[[1]] <= 1 & /@ M]]. I am new on Mathematica. Could you please elaborate your idea? $\endgroup$ – Filburt Oct 2 '17 at 0:29
  • $\begingroup$ I'm a little bit confused, can you provide an example of what you need? Does Pick[M, Or @@@ Outer[#1 + #2 <= 1 &, M, A]] returns what you need? $\endgroup$ – swish Oct 2 '17 at 0:42
  • 2
    $\begingroup$ I think an example input with the correct output would be helpful here, along with an explanation of what is intended. $\endgroup$ – march Oct 2 '17 at 0:54
  • 2
    $\begingroup$ Select[m, AllTrue[# + a, # <= 1 &] &] $\endgroup$ – Pillsy Oct 2 '17 at 1:27
6
$\begingroup$

How about:

Pick[M, LessEqualThan[1] /@ Max /@ Abs[M.Transpose[A]]]

{{0, 0, 0, 1}, {-(1/2), -(1/2), -(1/2), 1/2}, {-(1/2), 1/2, 1/2, 1/2}, {1/ 2, -(1/2), 1/2, 1/2}, {-1, 0, 0, 0}, {0, 0, 1, 0}, {1/2, 1/2, -(1/2), 1/ 2}, {0, -1, 0, 0}, {0, 1, 0, 0}, {0, 0, -1, 0}, {1, 0, 0, 0}, {-(1/2), -(1/2), 1/2, -(1/2)}, {1/2, 1/2, 1/2, -(1/2)}, {-(1/2), 1/ 2, -(1/2), -(1/2)}, {1/2, -(1/2), -(1/2), -(1/2)}, {0, 0, 0, -1}}

$\endgroup$
2
$\begingroup$

For the version of the question before Edit 2:

m = Range[0, 5];
a = -Range[15];
Pick[m, NonPositive[Max[# + a - 1] & /@ m]]
(* or Select[m, NonPositive[Max[# + a - 1]]&] *)

{0, 1, 2}

Update: For the general case, with M and A as in OP's Edit 2, simply change # + a -1 to #.Transpose[A] - 1:

Pick[M, NonPositive[Max[#.Transpose[A] - 1]& /@ M]]
Pick[M, UnitStep[1 - Max[#.Transpose[A]]] & /@ M, 1] 
Select[M, NonPositive[Max[#.Transpose[A] - 1]]&] 

all give

{{0,0,0,1}, {-(1/2),-(1/2),-(1/2),1/2}, {-(1/2),1/2,1/2,1/2}, {1/2,-(1/2),1/2,1/2}, <<9>>, {-(1/2),1/2,-(1/2),-(1/2)}, {1/2,-(1/2),-(1/2),-(1/2)}, {0,0,0,-1}}

$\endgroup$
  • $\begingroup$ Please take a look at my edited post $\endgroup$ – Filburt Oct 2 '17 at 1:50
  • $\begingroup$ @Filburt, that edit changes everything:) $\endgroup$ – kglr Oct 2 '17 at 1:53
2
$\begingroup$
Pick[M,Max /@ Outer[Abs[#1. #2] &, M, A, 1],1]

yields:

{{0, 0, 0, 1}, {-(1/2), -(1/2), -(1/2), 1/2}, {-(1/2), 1/2, 1/2, 1/
  2}, {1/2, -(1/2), 1/2, 1/2}, {-1, 0, 0, 0}, {0, 0, 1, 0}, {1/2, 1/
  2, -(1/2), 1/2}, {0, -1, 0, 0}, {0, 1, 0, 0}, {0, 0, -1, 0}, {1, 0, 
  0, 0}, {-(1/2), -(1/2), 1/2, -(1/2)}, {1/2, 1/2, 1/
  2, -(1/2)}, {-(1/2), 1/2, -(1/2), -(1/2)}, {1/
  2, -(1/2), -(1/2), -(1/2)}, {0, 0, 0, -1}}
$\endgroup$
2
$\begingroup$

One thing you can do is use Dot to take the inner product with all the elements of A at once, which makes it relatively easy to use Select and AllTrue:

Select[M, AllTrue[A.#, Abs[#] <= 1 &] &]
$\endgroup$

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.