2
$\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.

Improve this question
$\endgroup$
6
  • $\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, 2017 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, 2017 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, 2017 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, 2017 at 0:54
  • 2
    $\begingroup$ Select[m, AllTrue[# + a, # <= 1 &] &] $\endgroup$
    – Pillsy
    Oct 2, 2017 at 1:27

4 Answers 4

Reset to default
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}}

Improve this answer
$\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}}

Improve this answer
$\endgroup$
2
  • $\begingroup$ Please take a look at my edited post $\endgroup$
    – Filburt
    Oct 2, 2017 at 1:50
  • 1
    $\begingroup$ @Filburt, that edit changes everything:) $\endgroup$
    – kglr
    Oct 2, 2017 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}}
Improve this answer
$\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 &] &]
Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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